1 /* Expression translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
51 enum gfc_array_kind akind;
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
61 scalar = TREE_TYPE (scalar);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
63 akind, !(attr.pointer || attr.target));
67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
69 tree desc, type, etype;
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 etype = TREE_TYPE (scalar);
73 desc = gfc_create_var (type, "desc");
74 DECL_ARTIFICIAL (desc) = 1;
76 if (CONSTANT_CLASS_P (scalar))
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
84 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
85 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
86 etype = TREE_TYPE (etype);
87 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
88 gfc_get_dtype_rank_type (0, etype));
89 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
94 gfc_add_modify (&se->post, scalar,
95 fold_convert (TREE_TYPE (scalar),
96 gfc_conv_descriptor_data_get (desc)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
107 gfc_symbol *sym = expr->symtree->n.sym;
108 bool is_coarray = sym->attr.codimension;
109 gfc_expr *caf_expr = gfc_copy_expr (expr);
110 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
114 if (ref->type == REF_COMPONENT
115 && (ref->u.c.component->attr.allocatable
116 || ref->u.c.component->attr.pointer)
117 && (is_coarray || ref->u.c.component->attr.codimension))
122 if (last_caf_ref == NULL)
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
130 gfc_init_se (&se, outerse);
131 gfc_free_ref_list (last_caf_ref->next);
132 last_caf_ref->next = NULL;
133 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
134 se.want_pointer = comp_ref;
135 gfc_conv_expr (&se, caf_expr);
136 gfc_add_block_to_block (&outerse->pre, &se.pre);
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
172 vec<constructor_elt, va_gc> *init = NULL;
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
181 return build_constructor (TREE_TYPE (decl), init);
186 gfc_class_data_get (tree decl)
189 if (POINTER_TYPE_P (TREE_TYPE (decl)))
190 decl = build_fold_indirect_ref_loc (input_location, decl);
191 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
200 gfc_class_vptr_get (tree decl)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl))
207 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
208 if (POINTER_TYPE_P (TREE_TYPE (decl)))
209 decl = build_fold_indirect_ref_loc (input_location, decl);
210 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
219 gfc_class_len_get (tree decl)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl))
226 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
227 if (POINTER_TYPE_P (TREE_TYPE (decl)))
228 decl = build_fold_indirect_ref_loc (input_location, decl);
229 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
256 : build_zero_cst (gfc_charlen_type_node);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr, int fieldno)
266 vptr = build_fold_indirect_ref_loc (input_location, vptr);
267 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
269 field = fold_build3_loc (input_location, COMPONENT_REF,
270 TREE_TYPE (field), vptr, field,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl, int fieldno)
283 vptr = gfc_class_vptr_get (decl);
284 return vptr_field_get (vptr, fieldno);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
303 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
304 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
305 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
306 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
307 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl)
317 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
318 /* Always return size as an array index type. */
319 size = fold_convert (gfc_array_index_type, size);
325 gfc_vptr_size_get (tree vptr)
328 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
329 /* Always return size as an array index type. */
330 size = fold_convert (gfc_array_index_type, size);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
358 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
360 /* Find the last class reference. */
363 for (ref = e->ref; ref; ref = ref->next)
365 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
368 if (ref->type == REF_COMPONENT
369 && ref->u.c.component->ts.type == BT_CLASS)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
380 if (ref->next == NULL)
384 /* Remove and store all subsequent references after the
388 tail = class_ref->next;
389 class_ref->next = NULL;
391 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
397 base_expr = gfc_expr_to_initialize (e);
399 /* Restore the original tail expression. */
402 gfc_free_ref_list (class_ref->next);
403 class_ref->next = tail;
405 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
407 gfc_free_ref_list (e->ref);
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
417 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se, NULL);
427 gfc_conv_expr_descriptor (&se, e);
429 gfc_conv_expr (&se, e);
430 gfc_add_block_to_block (block, &se.pre);
431 vptr = gfc_get_vptr_from_expr (se.expr);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr == NULL_TREE)
437 if (UNLIMITED_POLY (e))
438 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
441 /* Return the vptr to the address of the declared type. */
442 vtab = gfc_find_derived_vtab (e->ts.u.derived);
443 vtable = vtab->backend_decl;
444 if (vtable == NULL_TREE)
445 vtable = gfc_get_symbol_decl (vtab);
446 vtable = gfc_build_addr_expr (NULL, vtable);
447 vtable = fold_convert (TREE_TYPE (vptr), vtable);
448 gfc_add_modify (block, vptr, vtable);
453 /* Reset the len for unlimited polymorphic objects. */
456 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
460 e = gfc_find_and_cut_at_last_class_ref (expr);
463 gfc_add_len_component (e);
464 gfc_init_se (&se_len, NULL);
465 gfc_conv_expr (&se_len, e);
466 gfc_add_modify (block, se_len.expr,
467 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
476 gfc_get_vptr_from_expr (tree expr)
481 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
483 type = TREE_TYPE (tmp);
486 if (GFC_CLASS_TYPE_P (type))
487 return gfc_class_vptr_get (tmp);
488 if (type != TYPE_CANONICAL (type))
489 type = TYPE_CANONICAL (type);
493 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
497 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
498 tmp = build_fold_indirect_ref_loc (input_location, tmp);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
501 return gfc_class_vptr_get (tmp);
508 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
511 tree tmp, tmp2, type;
513 gfc_conv_descriptor_data_set (block, lhs_desc,
514 gfc_conv_descriptor_data_get (rhs_desc));
515 gfc_conv_descriptor_offset_set (block, lhs_desc,
516 gfc_conv_descriptor_offset_get (rhs_desc));
518 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
519 gfc_conv_descriptor_dtype (rhs_desc));
521 /* Assign the dimension as range-ref. */
522 tmp = gfc_get_descriptor_dimension (lhs_desc);
523 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
525 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
526 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
527 gfc_index_zero_node, NULL_TREE, NULL_TREE);
528 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
529 gfc_index_zero_node, NULL_TREE, NULL_TREE);
530 gfc_add_modify (block, tmp, tmp2);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
540 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
541 gfc_typespec class_ts, tree vptr, bool optional,
542 bool optional_alloc_ptr)
545 tree cond_optional = NULL_TREE;
552 /* The derived type needs to be converted to a temporary
554 tmp = gfc_typenode_for_spec (&class_ts);
555 var = gfc_create_var (tmp, "class");
558 ctree = gfc_class_vptr_get (var);
560 if (vptr != NULL_TREE)
562 /* Use the dynamic vptr. */
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab = gfc_find_derived_vtab (e->ts.u.derived);
571 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
573 gfc_add_modify (&parmse->pre, ctree,
574 fold_convert (TREE_TYPE (ctree), tmp));
576 /* Now set the data field. */
577 ctree = gfc_class_data_get (var);
580 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
582 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
587 gfc_add_modify (&parmse->pre, ctree, tmp);
589 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse, e);
594 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
596 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
598 fold_convert (TREE_TYPE (tmp), null_pointer_node));
599 gfc_add_modify (&parmse->pre, ctree, tmp);
603 ss = gfc_walk_expr (e);
604 if (ss == gfc_ss_terminator)
607 gfc_conv_expr_reference (parmse, e);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts.u.derived->components->as)
613 type = get_scalar_to_descriptor_type (parmse->expr,
615 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
616 gfc_get_dtype (type));
618 parmse->expr = build3_loc (input_location, COND_EXPR,
619 TREE_TYPE (parmse->expr),
620 cond_optional, parmse->expr,
621 fold_convert (TREE_TYPE (parmse->expr),
623 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
627 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
629 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
631 fold_convert (TREE_TYPE (tmp),
633 gfc_add_modify (&parmse->pre, ctree, tmp);
639 gfc_init_block (&block);
643 parmse->use_offset = 1;
644 gfc_conv_expr_descriptor (parmse, e);
646 /* Detect any array references with vector subscripts. */
647 for (ref = e->ref; ref; ref = ref->next)
648 if (ref->type == REF_ARRAY
649 && ref->u.ar.type != AR_ELEMENT
650 && ref->u.ar.type != AR_FULL)
652 for (dim = 0; dim < ref->u.ar.dimen; dim++)
653 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
655 if (dim < ref->u.ar.dimen)
659 /* Array references with vector subscripts and non-variable expressions
660 need be converted to a one-based descriptor. */
661 if (ref || e->expr_type != EXPR_VARIABLE)
663 for (dim = 0; dim < e->rank; ++dim)
664 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
668 if (e->rank != class_ts.u.derived->components->as->rank)
670 gcc_assert (class_ts.u.derived->components->as->type
672 class_array_data_assign (&block, ctree, parmse->expr, false);
676 if (gfc_expr_attr (e).codimension)
677 parmse->expr = fold_build1_loc (input_location,
681 gfc_add_modify (&block, ctree, parmse->expr);
686 tmp = gfc_finish_block (&block);
688 gfc_init_block (&block);
689 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
691 tmp = build3_v (COND_EXPR, cond_optional, tmp,
692 gfc_finish_block (&block));
693 gfc_add_expr_to_block (&parmse->pre, tmp);
696 gfc_add_block_to_block (&parmse->pre, &block);
700 if (class_ts.u.derived->components->ts.type == BT_DERIVED
701 && class_ts.u.derived->components->ts.u.derived
702 ->attr.unlimited_polymorphic)
704 /* Take care about initializing the _len component correctly. */
705 ctree = gfc_class_len_get (var);
706 if (UNLIMITED_POLY (e))
711 len = gfc_copy_expr (e);
712 gfc_add_len_component (len);
713 gfc_init_se (&se, NULL);
714 gfc_conv_expr (&se, len);
716 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
717 cond_optional, se.expr,
718 fold_convert (TREE_TYPE (se.expr),
724 tmp = integer_zero_node;
725 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
728 /* Pass the address of the class object. */
729 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
731 if (optional && optional_alloc_ptr)
732 parmse->expr = build3_loc (input_location, COND_EXPR,
733 TREE_TYPE (parmse->expr),
734 cond_optional, parmse->expr,
735 fold_convert (TREE_TYPE (parmse->expr),
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
745 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
746 gfc_typespec class_ts, bool optional)
748 tree var, ctree, tmp;
753 gfc_init_block (&block);
756 for (ref = e->ref; ref; ref = ref->next)
758 if (ref->type == REF_COMPONENT
759 && ref->u.c.component->ts.type == BT_CLASS)
763 if (class_ref == NULL
764 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
765 tmp = e->symtree->n.sym->backend_decl;
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
771 ref = class_ref->next;
772 class_ref->next = NULL;
773 gfc_init_se (&tmpse, NULL);
774 gfc_conv_expr (&tmpse, e);
775 class_ref->next = ref;
779 var = gfc_typenode_for_spec (&class_ts);
780 var = gfc_create_var (var, "class");
782 ctree = gfc_class_vptr_get (var);
783 gfc_add_modify (&block, ctree,
784 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
786 ctree = gfc_class_data_get (var);
787 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
788 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
790 /* Pass the address of the class object. */
791 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
795 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
798 tmp = gfc_finish_block (&block);
800 gfc_init_block (&block);
801 tmp2 = gfc_class_data_get (var);
802 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
804 tmp2 = gfc_finish_block (&block);
806 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
808 gfc_add_expr_to_block (&parmse->pre, tmp);
811 gfc_add_block_to_block (&parmse->pre, &block);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
818 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
819 gfc_typespec class_ts)
827 /* The intrinsic type needs to be converted to a temporary
829 tmp = gfc_typenode_for_spec (&class_ts);
830 var = gfc_create_var (tmp, "class");
833 ctree = gfc_class_vptr_get (var);
835 vtab = gfc_find_vtab (&e->ts);
837 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
838 gfc_add_modify (&parmse->pre, ctree,
839 fold_convert (TREE_TYPE (ctree), tmp));
841 /* Now set the data field. */
842 ctree = gfc_class_data_get (var);
843 if (parmse->ss && parmse->ss->info->useflags)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse, e);
848 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
849 gfc_add_modify (&parmse->pre, ctree, tmp);
853 ss = gfc_walk_expr (e);
854 if (ss == gfc_ss_terminator)
857 gfc_conv_expr_reference (parmse, e);
858 if (class_ts.u.derived->components->as
859 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
861 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
863 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
864 TREE_TYPE (ctree), tmp);
867 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
868 gfc_add_modify (&parmse->pre, ctree, tmp);
873 parmse->use_offset = 1;
874 gfc_conv_expr_descriptor (parmse, e);
875 if (class_ts.u.derived->components->as->rank != e->rank)
877 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
878 TREE_TYPE (ctree), parmse->expr);
879 gfc_add_modify (&parmse->pre, ctree, tmp);
882 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
886 gcc_assert (class_ts.type == BT_CLASS);
887 if (class_ts.u.derived->components->ts.type == BT_DERIVED
888 && class_ts.u.derived->components->ts.u.derived
889 ->attr.unlimited_polymorphic)
891 ctree = gfc_class_len_get (var);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e->ts.type == BT_CHARACTER)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse->string_length)
899 tmp = parmse->string_length;
900 /* When the string_length is not yet set, then try the backend_decl of
902 else if (e->ts.u.cl->backend_decl)
903 tmp = e->ts.u.cl->backend_decl;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e, 0);
911 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
916 gfc_charlen_int_kind,
918 mpz_set_ui (e->ts.u.cl->length->value.integer,
919 e->value.character.length);
920 gfc_conv_const_charlen (e->ts.u.cl);
921 e->ts.u.cl->resolved = 1;
922 tmp = e->ts.u.cl->backend_decl;
926 gfc_error ("Can't compute the length of the char array at %L.",
932 tmp = integer_zero_node;
934 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
936 else if (class_ts.type == BT_CLASS
937 && class_ts.u.derived->components
938 && class_ts.u.derived->components->ts.u
939 .derived->attr.unlimited_polymorphic)
941 ctree = gfc_class_len_get (var);
942 gfc_add_modify (&parmse->pre, ctree,
943 fold_convert (TREE_TYPE (ctree),
946 /* Pass the address of the class object. */
947 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
963 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
964 bool elemental, bool copyback, bool optional,
965 bool optional_alloc_ptr)
971 tree cond = NULL_TREE;
972 tree slen = NULL_TREE;
976 bool full_array = false;
978 gfc_init_block (&block);
981 for (ref = e->ref; ref; ref = ref->next)
983 if (ref->type == REF_COMPONENT
984 && ref->u.c.component->ts.type == BT_CLASS)
987 if (ref->next == NULL)
991 if ((ref == NULL || class_ref == ref)
992 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
993 && (!class_ts.u.derived->components->as
994 || class_ts.u.derived->components->as->rank != -1))
997 /* Test for FULL_ARRAY. */
998 if (e->rank == 0 && gfc_expr_attr (e).codimension
999 && gfc_expr_attr (e).dimension)
1002 gfc_is_class_array_ref (e, &full_array);
1004 /* The derived type needs to be converted to a temporary
1006 tmp = gfc_typenode_for_spec (&class_ts);
1007 var = gfc_create_var (tmp, "class");
1010 ctree = gfc_class_data_get (var);
1011 if (class_ts.u.derived->components->as
1012 && e->rank != class_ts.u.derived->components->as->rank)
1016 tree type = get_scalar_to_descriptor_type (parmse->expr,
1018 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1019 gfc_get_dtype (type));
1021 tmp = gfc_class_data_get (parmse->expr);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1023 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1025 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1028 class_array_data_assign (&block, ctree, parmse->expr, false);
1032 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1033 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1034 TREE_TYPE (ctree), parmse->expr);
1035 gfc_add_modify (&block, ctree, parmse->expr);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1041 if (!elemental && full_array && copyback)
1043 if (class_ts.u.derived->components->as
1044 && e->rank != class_ts.u.derived->components->as->rank)
1047 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1048 gfc_conv_descriptor_data_get (ctree));
1050 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1053 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1057 ctree = gfc_class_vptr_get (var);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1063 if (gfc_is_class_array_function (e)
1064 && parmse->class_vptr != NULL_TREE)
1065 tmp = parmse->class_vptr;
1066 else if (class_ref == NULL
1067 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1069 tmp = e->symtree->n.sym->backend_decl;
1071 if (TREE_CODE (tmp) == FUNCTION_DECL)
1072 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1074 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1075 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1077 slen = build_zero_cst (size_type_node);
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1084 ref = class_ref->next;
1085 class_ref->next = NULL;
1086 gfc_init_se (&tmpse, NULL);
1087 gfc_conv_expr (&tmpse, e);
1088 class_ref->next = ref;
1090 slen = tmpse.string_length;
1093 gcc_assert (tmp != NULL_TREE);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1097 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1099 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1100 vptr = gfc_class_vptr_get (tmp);
1104 gfc_add_modify (&block, ctree,
1105 fold_convert (TREE_TYPE (ctree), vptr));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental && full_array && copyback)
1110 gfc_add_modify (&parmse->post, vptr,
1111 fold_convert (TREE_TYPE (vptr), ctree));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts.type == BT_CLASS
1115 && class_ts.u.derived->components
1116 && class_ts.u.derived->components->ts.u
1117 .derived->attr.unlimited_polymorphic)
1119 ctree = gfc_class_len_get (var);
1120 if (UNLIMITED_POLY (e))
1121 tmp = gfc_class_len_get (tmp);
1122 else if (e->ts.type == BT_CHARACTER)
1124 gcc_assert (slen != NULL_TREE);
1128 tmp = build_zero_cst (size_type_node);
1129 gfc_add_modify (&parmse->pre, ctree,
1130 fold_convert (TREE_TYPE (ctree), tmp));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental && full_array && copyback)
1135 gfc_add_modify (&parmse->post, tmp,
1136 fold_convert (TREE_TYPE (tmp), ctree));
1143 cond = gfc_conv_expr_present (e->symtree->n.sym);
1144 /* parmse->pre may contain some preparatory instructions for the
1145 temporary array descriptor. Those may only be executed when the
1146 optional argument is set, therefore add parmse->pre's instructions
1147 to block, which is later guarded by an if (optional_arg_given). */
1148 gfc_add_block_to_block (&parmse->pre, &block);
1149 block.head = parmse->pre.head;
1150 parmse->pre.head = NULL_TREE;
1151 tmp = gfc_finish_block (&block);
1153 if (optional_alloc_ptr)
1154 tmp2 = build_empty_stmt (input_location);
1157 gfc_init_block (&block);
1159 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1160 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1161 null_pointer_node));
1162 tmp2 = gfc_finish_block (&block);
1165 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1167 gfc_add_expr_to_block (&parmse->pre, tmp);
1170 gfc_add_block_to_block (&parmse->pre, &block);
1172 /* Pass the address of the class object. */
1173 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1175 if (optional && optional_alloc_ptr)
1176 parmse->expr = build3_loc (input_location, COND_EXPR,
1177 TREE_TYPE (parmse->expr),
1179 fold_convert (TREE_TYPE (parmse->expr),
1180 null_pointer_node));
1184 /* Given a class array declaration and an index, returns the address
1185 of the referenced element. */
1188 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1191 tree data, size, tmp, ctmp, offset, ptr;
1193 data = data_comp != NULL_TREE ? data_comp :
1194 gfc_class_data_get (class_decl);
1195 size = gfc_class_vtab_size_get (class_decl);
1199 tmp = fold_convert (gfc_array_index_type,
1200 gfc_class_len_get (class_decl));
1201 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1202 gfc_array_index_type, size, tmp);
1203 tmp = fold_build2_loc (input_location, GT_EXPR,
1204 logical_type_node, tmp,
1205 build_zero_cst (TREE_TYPE (tmp)));
1206 size = fold_build3_loc (input_location, COND_EXPR,
1207 gfc_array_index_type, tmp, ctmp, size);
1210 offset = fold_build2_loc (input_location, MULT_EXPR,
1211 gfc_array_index_type,
1214 data = gfc_conv_descriptor_data_get (data);
1215 ptr = fold_convert (pvoid_type_node, data);
1216 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1217 return fold_convert (TREE_TYPE (data), ptr);
1221 /* Copies one class expression to another, assuming that if either
1222 'to' or 'from' are arrays they are packed. Should 'from' be
1223 NULL_TREE, the initialization expression for 'to' is used, assuming
1224 that the _vptr is set. */
1227 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1237 vec<tree, va_gc> *args;
1242 bool is_from_desc = false, is_to_class = false;
1245 /* To prevent warnings on uninitialized variables. */
1246 from_len = to_len = NULL_TREE;
1248 if (from != NULL_TREE)
1249 fcn = gfc_class_vtab_copy_get (from);
1251 fcn = gfc_class_vtab_copy_get (to);
1253 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1255 if (from != NULL_TREE)
1257 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1261 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1265 /* Check that from is a class. When the class is part of a coarray,
1266 then from is a common pointer and is to be used as is. */
1267 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1268 ? build_fold_indirect_ref (from) : from;
1270 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1271 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1272 ? gfc_class_data_get (from) : from;
1273 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1277 from_data = gfc_class_vtab_def_init_get (to);
1281 if (from != NULL_TREE && unlimited)
1282 from_len = gfc_class_len_or_zero_get (from);
1284 from_len = build_zero_cst (size_type_node);
1287 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1290 to_data = gfc_class_data_get (to);
1292 to_len = gfc_class_len_get (to);
1295 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1298 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1300 stmtblock_t loopbody;
1304 tree orig_nelems = nelems; /* Needed for bounds check. */
1306 gfc_init_block (&body);
1307 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1308 gfc_array_index_type, nelems,
1309 gfc_index_one_node);
1310 nelems = gfc_evaluate_now (tmp, &body);
1311 index = gfc_create_var (gfc_array_index_type, "S");
1315 from_ref = gfc_get_class_array_ref (index, from, from_data,
1317 vec_safe_push (args, from_ref);
1320 vec_safe_push (args, from_data);
1323 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1326 tmp = gfc_conv_array_data (to);
1327 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1328 to_ref = gfc_build_addr_expr (NULL_TREE,
1329 gfc_build_array_ref (tmp, index, to));
1331 vec_safe_push (args, to_ref);
1333 /* Add bounds check. */
1334 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1337 const char *name = "<<unknown>>";
1341 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1343 from_len = gfc_conv_descriptor_size (from_data, 1);
1344 tmp = fold_build2_loc (input_location, NE_EXPR,
1345 logical_type_node, from_len, orig_nelems);
1346 msg = xasprintf ("Array bound mismatch for dimension %d "
1347 "of array '%s' (%%ld/%%ld)",
1350 gfc_trans_runtime_check (true, false, tmp, &body,
1351 &gfc_current_locus, msg,
1352 fold_convert (long_integer_type_node, orig_nelems),
1353 fold_convert (long_integer_type_node, from_len));
1358 tmp = build_call_vec (fcn_type, fcn, args);
1360 /* Build the body of the loop. */
1361 gfc_init_block (&loopbody);
1362 gfc_add_expr_to_block (&loopbody, tmp);
1364 /* Build the loop and return. */
1365 gfc_init_loopinfo (&loop);
1367 loop.from[0] = gfc_index_zero_node;
1368 loop.loopvar[0] = index;
1369 loop.to[0] = nelems;
1370 gfc_trans_scalarizing_loops (&loop, &loopbody);
1371 gfc_init_block (&ifbody);
1372 gfc_add_block_to_block (&ifbody, &loop.pre);
1373 stdcopy = gfc_finish_block (&ifbody);
1374 /* In initialization mode from_len is a constant zero. */
1375 if (unlimited && !integer_zerop (from_len))
1377 vec_safe_push (args, from_len);
1378 vec_safe_push (args, to_len);
1379 tmp = build_call_vec (fcn_type, fcn, args);
1380 /* Build the body of the loop. */
1381 gfc_init_block (&loopbody);
1382 gfc_add_expr_to_block (&loopbody, tmp);
1384 /* Build the loop and return. */
1385 gfc_init_loopinfo (&loop);
1387 loop.from[0] = gfc_index_zero_node;
1388 loop.loopvar[0] = index;
1389 loop.to[0] = nelems;
1390 gfc_trans_scalarizing_loops (&loop, &loopbody);
1391 gfc_init_block (&ifbody);
1392 gfc_add_block_to_block (&ifbody, &loop.pre);
1393 extcopy = gfc_finish_block (&ifbody);
1395 tmp = fold_build2_loc (input_location, GT_EXPR,
1396 logical_type_node, from_len,
1397 build_zero_cst (TREE_TYPE (from_len)));
1398 tmp = fold_build3_loc (input_location, COND_EXPR,
1399 void_type_node, tmp, extcopy, stdcopy);
1400 gfc_add_expr_to_block (&body, tmp);
1401 tmp = gfc_finish_block (&body);
1405 gfc_add_expr_to_block (&body, stdcopy);
1406 tmp = gfc_finish_block (&body);
1408 gfc_cleanup_loop (&loop);
1412 gcc_assert (!is_from_desc);
1413 vec_safe_push (args, from_data);
1414 vec_safe_push (args, to_data);
1415 stdcopy = build_call_vec (fcn_type, fcn, args);
1417 /* In initialization mode from_len is a constant zero. */
1418 if (unlimited && !integer_zerop (from_len))
1420 vec_safe_push (args, from_len);
1421 vec_safe_push (args, to_len);
1422 extcopy = build_call_vec (fcn_type, fcn, args);
1423 tmp = fold_build2_loc (input_location, GT_EXPR,
1424 logical_type_node, from_len,
1425 build_zero_cst (TREE_TYPE (from_len)));
1426 tmp = fold_build3_loc (input_location, COND_EXPR,
1427 void_type_node, tmp, extcopy, stdcopy);
1433 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1434 if (from == NULL_TREE)
1437 cond = fold_build2_loc (input_location, NE_EXPR,
1439 from_data, null_pointer_node);
1440 tmp = fold_build3_loc (input_location, COND_EXPR,
1441 void_type_node, cond,
1442 tmp, build_empty_stmt (input_location));
1450 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1452 gfc_actual_arglist *actual;
1457 actual = gfc_get_actual_arglist ();
1458 actual->expr = gfc_copy_expr (rhs);
1459 actual->next = gfc_get_actual_arglist ();
1460 actual->next->expr = gfc_copy_expr (lhs);
1461 ppc = gfc_copy_expr (obj);
1462 gfc_add_vptr_component (ppc);
1463 gfc_add_component_ref (ppc, "_copy");
1464 ppc_code = gfc_get_code (EXEC_CALL);
1465 ppc_code->resolved_sym = ppc->symtree->n.sym;
1466 /* Although '_copy' is set to be elemental in class.c, it is
1467 not staying that way. Find out why, sometime.... */
1468 ppc_code->resolved_sym->attr.elemental = 1;
1469 ppc_code->ext.actual = actual;
1470 ppc_code->expr1 = ppc;
1471 /* Since '_copy' is elemental, the scalarizer will take care
1472 of arrays in gfc_trans_call. */
1473 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1474 gfc_free_statements (ppc_code);
1476 if (UNLIMITED_POLY(obj))
1478 /* Check if rhs is non-NULL. */
1480 gfc_init_se (&src, NULL);
1481 gfc_conv_expr (&src, rhs);
1482 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1483 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1484 src.expr, fold_convert (TREE_TYPE (src.expr),
1485 null_pointer_node));
1486 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1487 build_empty_stmt (input_location));
1493 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1494 A MEMCPY is needed to copy the full data from the default initializer
1495 of the dynamic type. */
1498 gfc_trans_class_init_assign (gfc_code *code)
1502 gfc_se dst,src,memsz;
1503 gfc_expr *lhs, *rhs, *sz;
1505 gfc_start_block (&block);
1507 lhs = gfc_copy_expr (code->expr1);
1509 rhs = gfc_copy_expr (code->expr1);
1510 gfc_add_vptr_component (rhs);
1512 /* Make sure that the component backend_decls have been built, which
1513 will not have happened if the derived types concerned have not
1515 gfc_get_derived_type (rhs->ts.u.derived);
1516 gfc_add_def_init_component (rhs);
1517 /* The _def_init is always scalar. */
1520 if (code->expr1->ts.type == BT_CLASS
1521 && CLASS_DATA (code->expr1)->attr.dimension)
1523 gfc_array_spec *tmparr = gfc_get_array_spec ();
1524 *tmparr = *CLASS_DATA (code->expr1)->as;
1525 /* Adding the array ref to the class expression results in correct
1526 indexing to the dynamic type. */
1527 gfc_add_full_array_ref (lhs, tmparr);
1528 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1532 /* Scalar initialization needs the _data component. */
1533 gfc_add_data_component (lhs);
1534 sz = gfc_copy_expr (code->expr1);
1535 gfc_add_vptr_component (sz);
1536 gfc_add_size_component (sz);
1538 gfc_init_se (&dst, NULL);
1539 gfc_init_se (&src, NULL);
1540 gfc_init_se (&memsz, NULL);
1541 gfc_conv_expr (&dst, lhs);
1542 gfc_conv_expr (&src, rhs);
1543 gfc_conv_expr (&memsz, sz);
1544 gfc_add_block_to_block (&block, &src.pre);
1545 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1547 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1549 if (UNLIMITED_POLY(code->expr1))
1551 /* Check if _def_init is non-NULL. */
1552 tree cond = fold_build2_loc (input_location, NE_EXPR,
1553 logical_type_node, src.expr,
1554 fold_convert (TREE_TYPE (src.expr),
1555 null_pointer_node));
1556 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1557 tmp, build_empty_stmt (input_location));
1561 if (code->expr1->symtree->n.sym->attr.optional
1562 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1564 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1565 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1567 build_empty_stmt (input_location));
1570 gfc_add_expr_to_block (&block, tmp);
1572 return gfc_finish_block (&block);
1576 /* End of prototype trans-class.c */
1580 realloc_lhs_warning (bt type, bool array, locus *where)
1582 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1583 gfc_warning (OPT_Wrealloc_lhs,
1584 "Code for reallocating the allocatable array at %L will "
1586 else if (warn_realloc_lhs_all)
1587 gfc_warning (OPT_Wrealloc_lhs_all,
1588 "Code for reallocating the allocatable variable at %L "
1589 "will be added", where);
1593 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1596 /* Copy the scalarization loop variables. */
1599 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1602 dest->loop = src->loop;
1606 /* Initialize a simple expression holder.
1608 Care must be taken when multiple se are created with the same parent.
1609 The child se must be kept in sync. The easiest way is to delay creation
1610 of a child se until after after the previous se has been translated. */
1613 gfc_init_se (gfc_se * se, gfc_se * parent)
1615 memset (se, 0, sizeof (gfc_se));
1616 gfc_init_block (&se->pre);
1617 gfc_init_block (&se->post);
1619 se->parent = parent;
1622 gfc_copy_se_loopvars (se, parent);
1626 /* Advances to the next SS in the chain. Use this rather than setting
1627 se->ss = se->ss->next because all the parents needs to be kept in sync.
1631 gfc_advance_se_ss_chain (gfc_se * se)
1636 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1639 /* Walk down the parent chain. */
1642 /* Simple consistency check. */
1643 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1644 || p->parent->ss->nested_ss == p->ss);
1646 /* If we were in a nested loop, the next scalarized expression can be
1647 on the parent ss' next pointer. Thus we should not take the next
1648 pointer blindly, but rather go up one nest level as long as next
1649 is the end of chain. */
1651 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1661 /* Ensures the result of the expression as either a temporary variable
1662 or a constant so that it can be used repeatedly. */
1665 gfc_make_safe_expr (gfc_se * se)
1669 if (CONSTANT_CLASS_P (se->expr))
1672 /* We need a temporary for this result. */
1673 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1674 gfc_add_modify (&se->pre, var, se->expr);
1679 /* Return an expression which determines if a dummy parameter is present.
1680 Also used for arguments to procedures with multiple entry points. */
1683 gfc_conv_expr_present (gfc_symbol * sym)
1687 gcc_assert (sym->attr.dummy);
1688 decl = gfc_get_symbol_decl (sym);
1690 /* Intrinsic scalars with VALUE attribute which are passed by value
1691 use a hidden argument to denote the present status. */
1692 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1693 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1694 && !sym->attr.dimension)
1696 char name[GFC_MAX_SYMBOL_LEN + 2];
1699 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1701 strcpy (&name[1], sym->name);
1702 tree_name = get_identifier (name);
1704 /* Walk function argument list to find hidden arg. */
1705 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1706 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1707 if (DECL_NAME (cond) == tree_name)
1714 if (TREE_CODE (decl) != PARM_DECL)
1716 /* Array parameters use a temporary descriptor, we want the real
1718 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1719 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1720 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1723 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1724 fold_convert (TREE_TYPE (decl), null_pointer_node));
1726 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1727 as actual argument to denote absent dummies. For array descriptors,
1728 we thus also need to check the array descriptor. For BT_CLASS, it
1729 can also occur for scalars and F2003 due to type->class wrapping and
1730 class->class wrapping. Note further that BT_CLASS always uses an
1731 array descriptor for arrays, also for explicit-shape/assumed-size. */
1733 if (!sym->attr.allocatable
1734 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1735 || (sym->ts.type == BT_CLASS
1736 && !CLASS_DATA (sym)->attr.allocatable
1737 && !CLASS_DATA (sym)->attr.class_pointer))
1738 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1739 || sym->ts.type == BT_CLASS))
1743 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1744 || sym->as->type == AS_ASSUMED_RANK
1745 || sym->attr.codimension))
1746 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1748 tmp = build_fold_indirect_ref_loc (input_location, decl);
1749 if (sym->ts.type == BT_CLASS)
1750 tmp = gfc_class_data_get (tmp);
1751 tmp = gfc_conv_array_data (tmp);
1753 else if (sym->ts.type == BT_CLASS)
1754 tmp = gfc_class_data_get (decl);
1758 if (tmp != NULL_TREE)
1760 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1761 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1762 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1763 logical_type_node, cond, tmp);
1771 /* Converts a missing, dummy argument into a null or zero. */
1774 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1779 present = gfc_conv_expr_present (arg->symtree->n.sym);
1783 /* Create a temporary and convert it to the correct type. */
1784 tmp = gfc_get_int_type (kind);
1785 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1788 /* Test for a NULL value. */
1789 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1790 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1791 tmp = gfc_evaluate_now (tmp, &se->pre);
1792 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1796 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1798 build_zero_cst (TREE_TYPE (se->expr)));
1799 tmp = gfc_evaluate_now (tmp, &se->pre);
1803 if (ts.type == BT_CHARACTER)
1805 tmp = build_int_cst (gfc_charlen_type_node, 0);
1806 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1807 present, se->string_length, tmp);
1808 tmp = gfc_evaluate_now (tmp, &se->pre);
1809 se->string_length = tmp;
1815 /* Get the character length of an expression, looking through gfc_refs
1819 gfc_get_expr_charlen (gfc_expr *e)
1824 gcc_assert (e->expr_type == EXPR_VARIABLE
1825 && e->ts.type == BT_CHARACTER);
1827 length = NULL; /* To silence compiler warning. */
1829 if (is_subref_array (e) && e->ts.u.cl->length)
1832 gfc_init_se (&tmpse, NULL);
1833 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1834 e->ts.u.cl->backend_decl = tmpse.expr;
1838 /* First candidate: if the variable is of type CHARACTER, the
1839 expression's length could be the length of the character
1841 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1842 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1844 /* Look through the reference chain for component references. */
1845 for (r = e->ref; r; r = r->next)
1850 if (r->u.c.component->ts.type == BT_CHARACTER)
1851 length = r->u.c.component->ts.u.cl->backend_decl;
1859 /* We should never got substring references here. These will be
1860 broken down by the scalarizer. */
1866 gcc_assert (length != NULL);
1871 /* Return for an expression the backend decl of the coarray. */
1874 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1880 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1882 /* Not-implemented diagnostic. */
1883 if (expr->symtree->n.sym->ts.type == BT_CLASS
1884 && UNLIMITED_POLY (expr->symtree->n.sym)
1885 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1886 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1887 "%L is not supported", &expr->where);
1889 for (ref = expr->ref; ref; ref = ref->next)
1890 if (ref->type == REF_COMPONENT)
1892 if (ref->u.c.component->ts.type == BT_CLASS
1893 && UNLIMITED_POLY (ref->u.c.component)
1894 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1895 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1896 "component at %L is not supported", &expr->where);
1899 /* Make sure the backend_decl is present before accessing it. */
1900 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1901 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1902 : expr->symtree->n.sym->backend_decl;
1904 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1906 if (expr->ref && expr->ref->type == REF_ARRAY)
1908 caf_decl = gfc_class_data_get (caf_decl);
1909 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1912 for (ref = expr->ref; ref; ref = ref->next)
1914 if (ref->type == REF_COMPONENT
1915 && strcmp (ref->u.c.component->name, "_data") != 0)
1917 caf_decl = gfc_class_data_get (caf_decl);
1918 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1922 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1926 if (expr->symtree->n.sym->attr.codimension)
1929 /* The following code assumes that the coarray is a component reachable via
1930 only scalar components/variables; the Fortran standard guarantees this. */
1932 for (ref = expr->ref; ref; ref = ref->next)
1933 if (ref->type == REF_COMPONENT)
1935 gfc_component *comp = ref->u.c.component;
1937 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1938 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1939 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1940 TREE_TYPE (comp->backend_decl), caf_decl,
1941 comp->backend_decl, NULL_TREE);
1942 if (comp->ts.type == BT_CLASS)
1944 caf_decl = gfc_class_data_get (caf_decl);
1945 if (CLASS_DATA (comp)->attr.codimension)
1951 if (comp->attr.codimension)
1957 gcc_assert (found && caf_decl);
1962 /* Obtain the Coarray token - and optionally also the offset. */
1965 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1966 tree se_expr, gfc_expr *expr)
1970 /* Coarray token. */
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1973 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1974 == GFC_ARRAY_ALLOCATABLE
1975 || expr->symtree->n.sym->attr.select_type_temporary);
1976 *token = gfc_conv_descriptor_token (caf_decl);
1978 else if (DECL_LANG_SPECIFIC (caf_decl)
1979 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1980 *token = GFC_DECL_TOKEN (caf_decl);
1983 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1984 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1985 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1991 /* Offset between the coarray base address and the address wanted. */
1992 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1993 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1994 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1995 *offset = build_int_cst (gfc_array_index_type, 0);
1996 else if (DECL_LANG_SPECIFIC (caf_decl)
1997 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1998 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
1999 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2000 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2002 *offset = build_int_cst (gfc_array_index_type, 0);
2004 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2005 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2007 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2008 tmp = gfc_conv_descriptor_data_get (tmp);
2010 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2011 tmp = gfc_conv_descriptor_data_get (se_expr);
2014 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2018 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2019 *offset, fold_convert (gfc_array_index_type, tmp));
2021 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2022 && expr->symtree->n.sym->attr.codimension
2023 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2025 gfc_expr *base_expr = gfc_copy_expr (expr);
2026 gfc_ref *ref = base_expr->ref;
2029 // Iterate through the refs until the last one.
2033 if (ref->type == REF_ARRAY
2034 && ref->u.ar.type != AR_FULL)
2036 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2038 for (i = 0; i < ranksum; ++i)
2040 ref->u.ar.start[i] = NULL;
2041 ref->u.ar.end[i] = NULL;
2043 ref->u.ar.type = AR_FULL;
2045 gfc_init_se (&base_se, NULL);
2046 if (gfc_caf_attr (base_expr).dimension)
2048 gfc_conv_expr_descriptor (&base_se, base_expr);
2049 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2053 gfc_conv_expr (&base_se, base_expr);
2057 gfc_free_expr (base_expr);
2058 gfc_add_block_to_block (&se->pre, &base_se.pre);
2059 gfc_add_block_to_block (&se->post, &base_se.post);
2061 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2062 tmp = gfc_conv_descriptor_data_get (caf_decl);
2065 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2069 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2070 fold_convert (gfc_array_index_type, *offset),
2071 fold_convert (gfc_array_index_type, tmp));
2075 /* Convert the coindex of a coarray into an image index; the result is
2076 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2077 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2080 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2083 tree lbound, ubound, extent, tmp, img_idx;
2087 for (ref = e->ref; ref; ref = ref->next)
2088 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2090 gcc_assert (ref != NULL);
2092 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2094 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2098 img_idx = integer_zero_node;
2099 extent = integer_one_node;
2100 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2101 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2103 gfc_init_se (&se, NULL);
2104 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2105 gfc_add_block_to_block (block, &se.pre);
2106 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2107 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2108 integer_type_node, se.expr,
2109 fold_convert(integer_type_node, lbound));
2110 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2112 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
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 tmp = fold_convert (integer_type_node, tmp);
2119 extent = fold_build2_loc (input_location, MULT_EXPR,
2120 integer_type_node, extent, tmp);
2124 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2126 gfc_init_se (&se, NULL);
2127 gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
2128 gfc_add_block_to_block (block, &se.pre);
2129 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2130 lbound = fold_convert (integer_type_node, lbound);
2131 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2132 integer_type_node, se.expr, lbound);
2133 tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
2135 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2137 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2139 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2140 ubound = fold_convert (integer_type_node, ubound);
2141 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2142 integer_type_node, ubound, lbound);
2143 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2144 tmp, integer_one_node);
2145 extent = fold_build2_loc (input_location, MULT_EXPR,
2146 integer_type_node, extent, tmp);
2149 img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2150 img_idx, integer_one_node);
2155 /* For each character array constructor subexpression without a ts.u.cl->length,
2156 replace it by its first element (if there aren't any elements, the length
2157 should already be set to zero). */
2160 flatten_array_ctors_without_strlen (gfc_expr* e)
2162 gfc_actual_arglist* arg;
2168 switch (e->expr_type)
2172 flatten_array_ctors_without_strlen (e->value.op.op1);
2173 flatten_array_ctors_without_strlen (e->value.op.op2);
2177 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2181 for (arg = e->value.function.actual; arg; arg = arg->next)
2182 flatten_array_ctors_without_strlen (arg->expr);
2187 /* We've found what we're looking for. */
2188 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2193 gcc_assert (e->value.constructor);
2195 c = gfc_constructor_first (e->value.constructor);
2199 flatten_array_ctors_without_strlen (new_expr);
2200 gfc_replace_expr (e, new_expr);
2204 /* Otherwise, fall through to handle constructor elements. */
2206 case EXPR_STRUCTURE:
2207 for (c = gfc_constructor_first (e->value.constructor);
2208 c; c = gfc_constructor_next (c))
2209 flatten_array_ctors_without_strlen (c->expr);
2219 /* Generate code to initialize a string length variable. Returns the
2220 value. For array constructors, cl->length might be NULL and in this case,
2221 the first element of the constructor is needed. expr is the original
2222 expression so we can access it but can be NULL if this is not needed. */
2225 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2229 gfc_init_se (&se, NULL);
2231 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2234 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2235 "flatten" array constructors by taking their first element; all elements
2236 should be the same length or a cl->length should be present. */
2239 gfc_expr* expr_flat;
2241 expr_flat = gfc_copy_expr (expr);
2242 flatten_array_ctors_without_strlen (expr_flat);
2243 gfc_resolve_expr (expr_flat);
2245 gfc_conv_expr (&se, expr_flat);
2246 gfc_add_block_to_block (pblock, &se.pre);
2247 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2249 gfc_free_expr (expr_flat);
2253 /* Convert cl->length. */
2255 gcc_assert (cl->length);
2257 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2258 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2259 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2260 gfc_add_block_to_block (pblock, &se.pre);
2262 if (cl->backend_decl)
2263 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2265 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2270 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2271 const char *name, locus *where)
2281 type = gfc_get_character_type (kind, ref->u.ss.length);
2282 type = build_pointer_type (type);
2284 gfc_init_se (&start, se);
2285 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2286 gfc_add_block_to_block (&se->pre, &start.pre);
2288 if (integer_onep (start.expr))
2289 gfc_conv_string_parameter (se);
2294 /* Avoid multiple evaluation of substring start. */
2295 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2296 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2298 /* Change the start of the string. */
2299 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2302 tmp = build_fold_indirect_ref_loc (input_location,
2304 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2305 se->expr = gfc_build_addr_expr (type, tmp);
2308 /* Length = end + 1 - start. */
2309 gfc_init_se (&end, se);
2310 if (ref->u.ss.end == NULL)
2311 end.expr = se->string_length;
2314 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2315 gfc_add_block_to_block (&se->pre, &end.pre);
2319 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2320 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2322 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2324 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2325 logical_type_node, start.expr,
2328 /* Check lower bound. */
2329 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2331 build_one_cst (TREE_TYPE (start.expr)));
2332 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2333 logical_type_node, nonempty, fault);
2335 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2336 "is less than one", name);
2338 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2339 "is less than one");
2340 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2341 fold_convert (long_integer_type_node,
2345 /* Check upper bound. */
2346 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2347 end.expr, se->string_length);
2348 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2349 logical_type_node, nonempty, fault);
2351 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2352 "exceeds string length (%%ld)", name);
2354 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2355 "exceeds string length (%%ld)");
2356 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2357 fold_convert (long_integer_type_node, end.expr),
2358 fold_convert (long_integer_type_node,
2359 se->string_length));
2363 /* Try to calculate the length from the start and end expressions. */
2365 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2367 HOST_WIDE_INT i_len;
2369 i_len = gfc_mpz_get_hwi (length) + 1;
2373 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2374 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2378 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2379 fold_convert (gfc_charlen_type_node, end.expr),
2380 fold_convert (gfc_charlen_type_node, start.expr));
2381 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2382 build_int_cst (gfc_charlen_type_node, 1), tmp);
2383 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2384 tmp, build_int_cst (gfc_charlen_type_node, 0));
2387 se->string_length = tmp;
2391 /* Convert a derived type component reference. */
2394 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2402 c = ref->u.c.component;
2404 if (c->backend_decl == NULL_TREE
2405 && ref->u.c.sym != NULL)
2406 gfc_get_derived_type (ref->u.c.sym);
2408 field = c->backend_decl;
2409 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2411 context = DECL_FIELD_CONTEXT (field);
2413 /* Components can correspond to fields of different containing
2414 types, as components are created without context, whereas
2415 a concrete use of a component has the type of decl as context.
2416 So, if the type doesn't match, we search the corresponding
2417 FIELD_DECL in the parent type. To not waste too much time
2418 we cache this result in norestrict_decl.
2419 On the other hand, if the context is a UNION or a MAP (a
2420 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2422 if (context != TREE_TYPE (decl)
2423 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2424 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2426 tree f2 = c->norestrict_decl;
2427 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2428 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2429 if (TREE_CODE (f2) == FIELD_DECL
2430 && DECL_NAME (f2) == DECL_NAME (field))
2433 c->norestrict_decl = f2;
2437 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2438 && strcmp ("_data", c->name) == 0)
2440 /* Found a ref to the _data component. Store the associated ref to
2441 the vptr in se->class_vptr. */
2442 se->class_vptr = gfc_class_vptr_get (decl);
2445 se->class_vptr = NULL_TREE;
2447 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2448 decl, field, NULL_TREE);
2452 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2453 strlen () conditional below. */
2454 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2455 && !(c->attr.allocatable && c->ts.deferred)
2456 && !c->attr.pdt_string)
2458 tmp = c->ts.u.cl->backend_decl;
2459 /* Components must always be constant length. */
2460 gcc_assert (tmp && INTEGER_CST_P (tmp));
2461 se->string_length = tmp;
2464 if (gfc_deferred_strlen (c, &field))
2466 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2468 decl, field, NULL_TREE);
2469 se->string_length = tmp;
2472 if (((c->attr.pointer || c->attr.allocatable)
2473 && (!c->attr.dimension && !c->attr.codimension)
2474 && c->ts.type != BT_CHARACTER)
2475 || c->attr.proc_pointer)
2476 se->expr = build_fold_indirect_ref_loc (input_location,
2481 /* This function deals with component references to components of the
2482 parent type for derived type extensions. */
2484 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2492 c = ref->u.c.component;
2494 /* Return if the component is in the parent type. */
2495 for (cmp = dt->components; cmp; cmp = cmp->next)
2496 if (strcmp (c->name, cmp->name) == 0)
2499 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2500 parent.type = REF_COMPONENT;
2502 parent.u.c.sym = dt;
2503 parent.u.c.component = dt->components;
2505 if (dt->backend_decl == NULL)
2506 gfc_get_derived_type (dt);
2508 /* Build the reference and call self. */
2509 gfc_conv_component_ref (se, &parent);
2510 parent.u.c.sym = dt->components->ts.u.derived;
2511 parent.u.c.component = c;
2512 conv_parent_component_references (se, &parent);
2515 /* Return the contents of a variable. Also handles reference/pointer
2516 variables (all Fortran pointer references are implicit). */
2519 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2524 tree parent_decl = NULL_TREE;
2527 bool alternate_entry;
2530 bool first_time = true;
2532 sym = expr->symtree->n.sym;
2533 is_classarray = IS_CLASS_ARRAY (sym);
2537 gfc_ss_info *ss_info = ss->info;
2539 /* Check that something hasn't gone horribly wrong. */
2540 gcc_assert (ss != gfc_ss_terminator);
2541 gcc_assert (ss_info->expr == expr);
2543 /* A scalarized term. We already know the descriptor. */
2544 se->expr = ss_info->data.array.descriptor;
2545 se->string_length = ss_info->string_length;
2546 ref = ss_info->data.array.ref;
2548 gcc_assert (ref->type == REF_ARRAY
2549 && ref->u.ar.type != AR_ELEMENT);
2551 gfc_conv_tmp_array_ref (se);
2555 tree se_expr = NULL_TREE;
2557 se->expr = gfc_get_symbol_decl (sym);
2559 /* Deal with references to a parent results or entries by storing
2560 the current_function_decl and moving to the parent_decl. */
2561 return_value = sym->attr.function && sym->result == sym;
2562 alternate_entry = sym->attr.function && sym->attr.entry
2563 && sym->result == sym;
2564 entry_master = sym->attr.result
2565 && sym->ns->proc_name->attr.entry_master
2566 && !gfc_return_by_reference (sym->ns->proc_name);
2567 if (current_function_decl)
2568 parent_decl = DECL_CONTEXT (current_function_decl);
2570 if ((se->expr == parent_decl && return_value)
2571 || (sym->ns && sym->ns->proc_name
2573 && sym->ns->proc_name->backend_decl == parent_decl
2574 && (alternate_entry || entry_master)))
2579 /* Special case for assigning the return value of a function.
2580 Self recursive functions must have an explicit return value. */
2581 if (return_value && (se->expr == current_function_decl || parent_flag))
2582 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2584 /* Similarly for alternate entry points. */
2585 else if (alternate_entry
2586 && (sym->ns->proc_name->backend_decl == current_function_decl
2589 gfc_entry_list *el = NULL;
2591 for (el = sym->ns->entries; el; el = el->next)
2594 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2599 else if (entry_master
2600 && (sym->ns->proc_name->backend_decl == current_function_decl
2602 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2607 /* Procedure actual arguments. Look out for temporary variables
2608 with the same attributes as function values. */
2609 else if (!sym->attr.temporary
2610 && sym->attr.flavor == FL_PROCEDURE
2611 && se->expr != current_function_decl)
2613 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2615 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2616 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2622 /* Dereference the expression, where needed. Since characters
2623 are entirely different from other types, they are treated
2625 if (sym->ts.type == BT_CHARACTER)
2627 /* Dereference character pointer dummy arguments
2629 if ((sym->attr.pointer || sym->attr.allocatable)
2631 || sym->attr.function
2632 || sym->attr.result))
2633 se->expr = build_fold_indirect_ref_loc (input_location,
2637 else if (!sym->attr.value)
2639 /* Dereference temporaries for class array dummy arguments. */
2640 if (sym->attr.dummy && is_classarray
2641 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2643 if (!se->descriptor_only)
2644 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2646 se->expr = build_fold_indirect_ref_loc (input_location,
2650 /* Dereference non-character scalar dummy arguments. */
2651 if (sym->attr.dummy && !sym->attr.dimension
2652 && !(sym->attr.codimension && sym->attr.allocatable)
2653 && (sym->ts.type != BT_CLASS
2654 || (!CLASS_DATA (sym)->attr.dimension
2655 && !(CLASS_DATA (sym)->attr.codimension
2656 && CLASS_DATA (sym)->attr.allocatable))))
2657 se->expr = build_fold_indirect_ref_loc (input_location,
2660 /* Dereference scalar hidden result. */
2661 if (flag_f2c && sym->ts.type == BT_COMPLEX
2662 && (sym->attr.function || sym->attr.result)
2663 && !sym->attr.dimension && !sym->attr.pointer
2664 && !sym->attr.always_explicit)
2665 se->expr = build_fold_indirect_ref_loc (input_location,
2668 /* Dereference non-character, non-class pointer variables.
2669 These must be dummies, results, or scalars. */
2671 && (sym->attr.pointer || sym->attr.allocatable
2672 || gfc_is_associate_pointer (sym)
2673 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2675 || sym->attr.function
2677 || (!sym->attr.dimension
2678 && (!sym->attr.codimension || !sym->attr.allocatable))))
2679 se->expr = build_fold_indirect_ref_loc (input_location,
2681 /* Now treat the class array pointer variables accordingly. */
2682 else if (sym->ts.type == BT_CLASS
2684 && (CLASS_DATA (sym)->attr.dimension
2685 || CLASS_DATA (sym)->attr.codimension)
2686 && ((CLASS_DATA (sym)->as
2687 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2688 || CLASS_DATA (sym)->attr.allocatable
2689 || CLASS_DATA (sym)->attr.class_pointer))
2690 se->expr = build_fold_indirect_ref_loc (input_location,
2692 /* And the case where a non-dummy, non-result, non-function,
2693 non-allotable and non-pointer classarray is present. This case was
2694 previously covered by the first if, but with introducing the
2695 condition !is_classarray there, that case has to be covered
2697 else if (sym->ts.type == BT_CLASS
2699 && !sym->attr.function
2700 && !sym->attr.result
2701 && (CLASS_DATA (sym)->attr.dimension
2702 || CLASS_DATA (sym)->attr.codimension)
2704 || !CLASS_DATA (sym)->attr.allocatable)
2705 && !CLASS_DATA (sym)->attr.class_pointer)
2706 se->expr = build_fold_indirect_ref_loc (input_location,
2713 /* For character variables, also get the length. */
2714 if (sym->ts.type == BT_CHARACTER)
2716 /* If the character length of an entry isn't set, get the length from
2717 the master function instead. */
2718 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2719 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2721 se->string_length = sym->ts.u.cl->backend_decl;
2722 gcc_assert (se->string_length);
2730 /* Return the descriptor if that's what we want and this is an array
2731 section reference. */
2732 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2734 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2735 /* Return the descriptor for array pointers and allocations. */
2736 if (se->want_pointer
2737 && ref->next == NULL && (se->descriptor_only))
2740 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2741 /* Return a pointer to an element. */
2745 if (first_time && is_classarray && sym->attr.dummy
2746 && se->descriptor_only
2747 && !CLASS_DATA (sym)->attr.allocatable
2748 && !CLASS_DATA (sym)->attr.class_pointer
2749 && CLASS_DATA (sym)->as
2750 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2751 && strcmp ("_data", ref->u.c.component->name) == 0)
2752 /* Skip the first ref of a _data component, because for class
2753 arrays that one is already done by introducing a temporary
2754 array descriptor. */
2757 if (ref->u.c.sym->attr.extension)
2758 conv_parent_component_references (se, ref);
2760 gfc_conv_component_ref (se, ref);
2761 if (!ref->next && ref->u.c.sym->attr.codimension
2762 && se->want_pointer && se->descriptor_only)
2768 gfc_conv_substring (se, ref, expr->ts.kind,
2769 expr->symtree->name, &expr->where);
2779 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2781 if (se->want_pointer)
2783 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2784 gfc_conv_string_parameter (se);
2786 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2791 /* Unary ops are easy... Or they would be if ! was a valid op. */
2794 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2799 gcc_assert (expr->ts.type != BT_CHARACTER);
2800 /* Initialize the operand. */
2801 gfc_init_se (&operand, se);
2802 gfc_conv_expr_val (&operand, expr->value.op.op1);
2803 gfc_add_block_to_block (&se->pre, &operand.pre);
2805 type = gfc_typenode_for_spec (&expr->ts);
2807 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2808 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2809 All other unary operators have an equivalent GIMPLE unary operator. */
2810 if (code == TRUTH_NOT_EXPR)
2811 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2812 build_int_cst (type, 0));
2814 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2818 /* Expand power operator to optimal multiplications when a value is raised
2819 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2820 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2821 Programming", 3rd Edition, 1998. */
2823 /* This code is mostly duplicated from expand_powi in the backend.
2824 We establish the "optimal power tree" lookup table with the defined size.
2825 The items in the table are the exponents used to calculate the index
2826 exponents. Any integer n less than the value can get an "addition chain",
2827 with the first node being one. */
2828 #define POWI_TABLE_SIZE 256
2830 /* The table is from builtins.c. */
2831 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2833 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2834 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2835 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2836 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2837 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2838 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2839 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2840 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2841 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2842 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2843 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2844 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2845 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2846 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2847 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2848 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2849 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2850 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2851 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2852 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2853 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2854 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2855 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2856 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2857 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2858 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2859 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2860 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2861 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2862 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2863 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2864 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2867 /* If n is larger than lookup table's max index, we use the "window
2869 #define POWI_WINDOW_SIZE 3
2871 /* Recursive function to expand the power operator. The temporary
2872 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2874 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2881 if (n < POWI_TABLE_SIZE)
2886 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2887 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2891 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2892 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2893 op1 = gfc_conv_powi (se, digit, tmpvar);
2897 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2901 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2902 tmp = gfc_evaluate_now (tmp, &se->pre);
2904 if (n < POWI_TABLE_SIZE)
2911 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2912 return 1. Else return 0 and a call to runtime library functions
2913 will have to be built. */
2915 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2920 tree vartmp[POWI_TABLE_SIZE];
2922 unsigned HOST_WIDE_INT n;
2924 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2926 /* If exponent is too large, we won't expand it anyway, so don't bother
2927 with large integer values. */
2928 if (!wi::fits_shwi_p (wrhs))
2931 m = wrhs.to_shwi ();
2932 /* Use the wide_int's routine to reliably get the absolute value on all
2933 platforms. Then convert it to a HOST_WIDE_INT like above. */
2934 n = wi::abs (wrhs).to_shwi ();
2936 type = TREE_TYPE (lhs);
2937 sgn = tree_int_cst_sgn (rhs);
2939 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2940 || optimize_size) && (m > 2 || m < -1))
2946 se->expr = gfc_build_const (type, integer_one_node);
2950 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2951 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2953 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2954 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2955 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2956 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2959 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2962 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2963 logical_type_node, tmp, cond);
2964 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2965 tmp, build_int_cst (type, 1),
2966 build_int_cst (type, 0));
2970 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2971 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2972 build_int_cst (type, -1),
2973 build_int_cst (type, 0));
2974 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2975 cond, build_int_cst (type, 1), tmp);
2979 memset (vartmp, 0, sizeof (vartmp));
2983 tmp = gfc_build_const (type, integer_one_node);
2984 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2988 se->expr = gfc_conv_powi (se, n, vartmp);
2994 /* Power op (**). Constant integer exponent has special handling. */
2997 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2999 tree gfc_int4_type_node;
3002 int res_ikind_1, res_ikind_2;
3007 gfc_init_se (&lse, se);
3008 gfc_conv_expr_val (&lse, expr->value.op.op1);
3009 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3010 gfc_add_block_to_block (&se->pre, &lse.pre);
3012 gfc_init_se (&rse, se);
3013 gfc_conv_expr_val (&rse, expr->value.op.op2);
3014 gfc_add_block_to_block (&se->pre, &rse.pre);
3016 if (expr->value.op.op2->ts.type == BT_INTEGER
3017 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3018 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3021 gfc_int4_type_node = gfc_get_int_type (4);
3023 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3024 library routine. But in the end, we have to convert the result back
3025 if this case applies -- with res_ikind_K, we keep track whether operand K
3026 falls into this case. */
3030 kind = expr->value.op.op1->ts.kind;
3031 switch (expr->value.op.op2->ts.type)
3034 ikind = expr->value.op.op2->ts.kind;
3039 rse.expr = convert (gfc_int4_type_node, rse.expr);
3040 res_ikind_2 = ikind;
3062 if (expr->value.op.op1->ts.type == BT_INTEGER)
3064 lse.expr = convert (gfc_int4_type_node, lse.expr);
3091 switch (expr->value.op.op1->ts.type)
3094 if (kind == 3) /* Case 16 was not handled properly above. */
3096 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3100 /* Use builtins for real ** int4. */
3106 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3110 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3114 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3118 /* Use the __builtin_powil() only if real(kind=16) is
3119 actually the C long double type. */
3120 if (!gfc_real16_is_float128)
3121 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3129 /* If we don't have a good builtin for this, go for the
3130 library function. */
3132 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3136 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3145 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3149 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3157 se->expr = build_call_expr_loc (input_location,
3158 fndecl, 2, lse.expr, rse.expr);
3160 /* Convert the result back if it is of wrong integer kind. */
3161 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3163 /* We want the maximum of both operand kinds as result. */
3164 if (res_ikind_1 < res_ikind_2)
3165 res_ikind_1 = res_ikind_2;
3166 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3171 /* Generate code to allocate a string temporary. */
3174 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3179 if (gfc_can_put_var_on_stack (len))
3181 /* Create a temporary variable to hold the result. */
3182 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3183 TREE_TYPE (len), len,
3184 build_int_cst (TREE_TYPE (len), 1));
3185 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3187 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3188 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3190 tmp = build_array_type (TREE_TYPE (type), tmp);
3192 var = gfc_create_var (tmp, "str");
3193 var = gfc_build_addr_expr (type, var);
3197 /* Allocate a temporary to hold the result. */
3198 var = gfc_create_var (type, "pstr");
3199 gcc_assert (POINTER_TYPE_P (type));
3200 tmp = TREE_TYPE (type);
3201 if (TREE_CODE (tmp) == ARRAY_TYPE)
3202 tmp = TREE_TYPE (tmp);
3203 tmp = TYPE_SIZE_UNIT (tmp);
3204 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3205 fold_convert (size_type_node, len),
3206 fold_convert (size_type_node, tmp));
3207 tmp = gfc_call_malloc (&se->pre, type, tmp);
3208 gfc_add_modify (&se->pre, var, tmp);
3210 /* Free the temporary afterwards. */
3211 tmp = gfc_call_free (var);
3212 gfc_add_expr_to_block (&se->post, tmp);
3219 /* Handle a string concatenation operation. A temporary will be allocated to
3223 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3226 tree len, type, var, tmp, fndecl;
3228 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3229 && expr->value.op.op2->ts.type == BT_CHARACTER);
3230 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3232 gfc_init_se (&lse, se);
3233 gfc_conv_expr (&lse, expr->value.op.op1);
3234 gfc_conv_string_parameter (&lse);
3235 gfc_init_se (&rse, se);
3236 gfc_conv_expr (&rse, expr->value.op.op2);
3237 gfc_conv_string_parameter (&rse);
3239 gfc_add_block_to_block (&se->pre, &lse.pre);
3240 gfc_add_block_to_block (&se->pre, &rse.pre);
3242 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3243 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3244 if (len == NULL_TREE)
3246 len = fold_build2_loc (input_location, PLUS_EXPR,
3247 gfc_charlen_type_node,
3248 fold_convert (gfc_charlen_type_node,
3250 fold_convert (gfc_charlen_type_node,
3251 rse.string_length));
3254 type = build_pointer_type (type);
3256 var = gfc_conv_string_tmp (se, type, len);
3258 /* Do the actual concatenation. */
3259 if (expr->ts.kind == 1)
3260 fndecl = gfor_fndecl_concat_string;
3261 else if (expr->ts.kind == 4)
3262 fndecl = gfor_fndecl_concat_string_char4;
3266 tmp = build_call_expr_loc (input_location,
3267 fndecl, 6, len, var, lse.string_length, lse.expr,
3268 rse.string_length, rse.expr);
3269 gfc_add_expr_to_block (&se->pre, tmp);
3271 /* Add the cleanup for the operands. */
3272 gfc_add_block_to_block (&se->pre, &rse.post);
3273 gfc_add_block_to_block (&se->pre, &lse.post);
3276 se->string_length = len;
3279 /* Translates an op expression. Common (binary) cases are handled by this
3280 function, others are passed on. Recursion is used in either case.
3281 We use the fact that (op1.ts == op2.ts) (except for the power
3283 Operators need no special handling for scalarized expressions as long as
3284 they call gfc_conv_simple_val to get their operands.
3285 Character strings get special handling. */
3288 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3290 enum tree_code code;
3299 switch (expr->value.op.op)
3301 case INTRINSIC_PARENTHESES:
3302 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3303 && flag_protect_parens)
3305 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3306 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3311 case INTRINSIC_UPLUS:
3312 gfc_conv_expr (se, expr->value.op.op1);
3315 case INTRINSIC_UMINUS:
3316 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3320 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3323 case INTRINSIC_PLUS:
3327 case INTRINSIC_MINUS:
3331 case INTRINSIC_TIMES:
3335 case INTRINSIC_DIVIDE:
3336 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3337 an integer, we must round towards zero, so we use a
3339 if (expr->ts.type == BT_INTEGER)
3340 code = TRUNC_DIV_EXPR;
3345 case INTRINSIC_POWER:
3346 gfc_conv_power_op (se, expr);
3349 case INTRINSIC_CONCAT:
3350 gfc_conv_concat_op (se, expr);
3354 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3359 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3363 /* EQV and NEQV only work on logicals, but since we represent them
3364 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3366 case INTRINSIC_EQ_OS:
3374 case INTRINSIC_NE_OS:
3375 case INTRINSIC_NEQV:
3382 case INTRINSIC_GT_OS:
3389 case INTRINSIC_GE_OS:
3396 case INTRINSIC_LT_OS:
3403 case INTRINSIC_LE_OS:
3409 case INTRINSIC_USER:
3410 case INTRINSIC_ASSIGN:
3411 /* These should be converted into function calls by the frontend. */
3415 fatal_error (input_location, "Unknown intrinsic op");
3419 /* The only exception to this is **, which is handled separately anyway. */
3420 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3422 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3426 gfc_init_se (&lse, se);
3427 gfc_conv_expr (&lse, expr->value.op.op1);
3428 gfc_add_block_to_block (&se->pre, &lse.pre);
3431 gfc_init_se (&rse, se);
3432 gfc_conv_expr (&rse, expr->value.op.op2);
3433 gfc_add_block_to_block (&se->pre, &rse.pre);
3437 gfc_conv_string_parameter (&lse);
3438 gfc_conv_string_parameter (&rse);
3440 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3441 rse.string_length, rse.expr,
3442 expr->value.op.op1->ts.kind,
3444 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3445 gfc_add_block_to_block (&lse.post, &rse.post);
3448 type = gfc_typenode_for_spec (&expr->ts);
3452 /* The result of logical ops is always logical_type_node. */
3453 tmp = fold_build2_loc (input_location, code, logical_type_node,
3454 lse.expr, rse.expr);
3455 se->expr = convert (type, tmp);
3458 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3460 /* Add the post blocks. */
3461 gfc_add_block_to_block (&se->post, &rse.post);
3462 gfc_add_block_to_block (&se->post, &lse.post);
3465 /* If a string's length is one, we convert it to a single character. */
3468 gfc_string_to_single_character (tree len, tree str, int kind)
3472 || !tree_fits_uhwi_p (len)
3473 || !POINTER_TYPE_P (TREE_TYPE (str)))
3476 if (TREE_INT_CST_LOW (len) == 1)
3478 str = fold_convert (gfc_get_pchar_type (kind), str);
3479 return build_fold_indirect_ref_loc (input_location, str);
3483 && TREE_CODE (str) == ADDR_EXPR
3484 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3485 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3486 && array_ref_low_bound (TREE_OPERAND (str, 0))
3487 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3488 && TREE_INT_CST_LOW (len) > 1
3489 && TREE_INT_CST_LOW (len)
3490 == (unsigned HOST_WIDE_INT)
3491 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3493 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3494 ret = build_fold_indirect_ref_loc (input_location, ret);
3495 if (TREE_CODE (ret) == INTEGER_CST)
3497 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3498 int i, length = TREE_STRING_LENGTH (string_cst);
3499 const char *ptr = TREE_STRING_POINTER (string_cst);
3501 for (i = 1; i < length; i++)
3514 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3517 if (sym->backend_decl)
3519 /* This becomes the nominal_type in
3520 function.c:assign_parm_find_data_types. */
3521 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3522 /* This becomes the passed_type in
3523 function.c:assign_parm_find_data_types. C promotes char to
3524 integer for argument passing. */
3525 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3527 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3532 /* If we have a constant character expression, make it into an
3534 if ((*expr)->expr_type == EXPR_CONSTANT)
3539 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3540 (int)(*expr)->value.character.string[0]);
3541 if ((*expr)->ts.kind != gfc_c_int_kind)
3543 /* The expr needs to be compatible with a C int. If the
3544 conversion fails, then the 2 causes an ICE. */
3545 ts.type = BT_INTEGER;
3546 ts.kind = gfc_c_int_kind;
3547 gfc_convert_type (*expr, &ts, 2);
3550 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3552 if ((*expr)->ref == NULL)
3554 se->expr = gfc_string_to_single_character
3555 (build_int_cst (integer_type_node, 1),
3556 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3558 ((*expr)->symtree->n.sym)),
3563 gfc_conv_variable (se, *expr);
3564 se->expr = gfc_string_to_single_character
3565 (build_int_cst (integer_type_node, 1),
3566 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3574 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3575 if STR is a string literal, otherwise return -1. */
3578 gfc_optimize_len_trim (tree len, tree str, int kind)
3581 && TREE_CODE (str) == ADDR_EXPR
3582 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3583 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3584 && array_ref_low_bound (TREE_OPERAND (str, 0))
3585 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3586 && tree_fits_uhwi_p (len)
3587 && tree_to_uhwi (len) >= 1
3588 && tree_to_uhwi (len)
3589 == (unsigned HOST_WIDE_INT)
3590 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3592 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3593 folded = build_fold_indirect_ref_loc (input_location, folded);
3594 if (TREE_CODE (folded) == INTEGER_CST)
3596 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3597 int length = TREE_STRING_LENGTH (string_cst);
3598 const char *ptr = TREE_STRING_POINTER (string_cst);
3600 for (; length > 0; length--)
3601 if (ptr[length - 1] != ' ')
3610 /* Helper to build a call to memcmp. */
3613 build_memcmp_call (tree s1, tree s2, tree n)
3617 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3618 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3620 s1 = fold_convert (pvoid_type_node, s1);
3622 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3623 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3625 s2 = fold_convert (pvoid_type_node, s2);
3627 n = fold_convert (size_type_node, n);
3629 tmp = build_call_expr_loc (input_location,
3630 builtin_decl_explicit (BUILT_IN_MEMCMP),
3633 return fold_convert (integer_type_node, tmp);
3636 /* Compare two strings. If they are all single characters, the result is the
3637 subtraction of them. Otherwise, we build a library call. */
3640 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3641 enum tree_code code)
3647 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3648 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3650 sc1 = gfc_string_to_single_character (len1, str1, kind);
3651 sc2 = gfc_string_to_single_character (len2, str2, kind);
3653 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3655 /* Deal with single character specially. */
3656 sc1 = fold_convert (integer_type_node, sc1);
3657 sc2 = fold_convert (integer_type_node, sc2);
3658 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3662 if ((code == EQ_EXPR || code == NE_EXPR)
3664 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3666 /* If one string is a string literal with LEN_TRIM longer
3667 than the length of the second string, the strings
3669 int len = gfc_optimize_len_trim (len1, str1, kind);
3670 if (len > 0 && compare_tree_int (len2, len) < 0)
3671 return integer_one_node;
3672 len = gfc_optimize_len_trim (len2, str2, kind);
3673 if (len > 0 && compare_tree_int (len1, len) < 0)
3674 return integer_one_node;
3677 /* We can compare via memcpy if the strings are known to be equal
3678 in length and they are
3680 - kind=4 and the comparison is for (in)equality. */
3682 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3683 && tree_int_cst_equal (len1, len2)
3684 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3689 chartype = gfc_get_char_type (kind);
3690 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3691 fold_convert (TREE_TYPE(len1),
3692 TYPE_SIZE_UNIT(chartype)),
3694 return build_memcmp_call (str1, str2, tmp);
3697 /* Build a call for the comparison. */
3699 fndecl = gfor_fndecl_compare_string;
3701 fndecl = gfor_fndecl_compare_string_char4;
3705 return build_call_expr_loc (input_location, fndecl, 4,
3706 len1, str1, len2, str2);
3710 /* Return the backend_decl for a procedure pointer component. */
3713 get_proc_ptr_comp (gfc_expr *e)
3719 gfc_init_se (&comp_se, NULL);
3720 e2 = gfc_copy_expr (e);
3721 /* We have to restore the expr type later so that gfc_free_expr frees
3722 the exact same thing that was allocated.
3723 TODO: This is ugly. */
3724 old_type = e2->expr_type;
3725 e2->expr_type = EXPR_VARIABLE;
3726 gfc_conv_expr (&comp_se, e2);
3727 e2->expr_type = old_type;
3729 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3733 /* Convert a typebound function reference from a class object. */
3735 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3740 if (!VAR_P (base_object))
3742 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3743 gfc_add_modify (&se->pre, var, base_object);
3745 se->expr = gfc_class_vptr_get (base_object);
3746 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3748 while (ref && ref->next)
3750 gcc_assert (ref && ref->type == REF_COMPONENT);
3751 if (ref->u.c.sym->attr.extension)
3752 conv_parent_component_references (se, ref);
3753 gfc_conv_component_ref (se, ref);
3754 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3759 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3763 if (gfc_is_proc_ptr_comp (expr))
3764 tmp = get_proc_ptr_comp (expr);
3765 else if (sym->attr.dummy)
3767 tmp = gfc_get_symbol_decl (sym);
3768 if (sym->attr.proc_pointer)
3769 tmp = build_fold_indirect_ref_loc (input_location,
3771 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3772 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3776 if (!sym->backend_decl)
3777 sym->backend_decl = gfc_get_extern_function_decl (sym);
3779 TREE_USED (sym->backend_decl) = 1;
3781 tmp = sym->backend_decl;
3783 if (sym->attr.cray_pointee)
3785 /* TODO - make the cray pointee a pointer to a procedure,
3786 assign the pointer to it and use it for the call. This
3788 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3789 gfc_get_symbol_decl (sym->cp_pointer));
3790 tmp = gfc_evaluate_now (tmp, &se->pre);
3793 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3795 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3796 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3803 /* Initialize MAPPING. */
3806 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3808 mapping->syms = NULL;
3809 mapping->charlens = NULL;
3813 /* Free all memory held by MAPPING (but not MAPPING itself). */
3816 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3818 gfc_interface_sym_mapping *sym;
3819 gfc_interface_sym_mapping *nextsym;
3821 gfc_charlen *nextcl;
3823 for (sym = mapping->syms; sym; sym = nextsym)
3825 nextsym = sym->next;
3826 sym->new_sym->n.sym->formal = NULL;
3827 gfc_free_symbol (sym->new_sym->n.sym);
3828 gfc_free_expr (sym->expr);
3829 free (sym->new_sym);
3832 for (cl = mapping->charlens; cl; cl = nextcl)
3835 gfc_free_expr (cl->length);
3841 /* Return a copy of gfc_charlen CL. Add the returned structure to
3842 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3844 static gfc_charlen *
3845 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3848 gfc_charlen *new_charlen;
3850 new_charlen = gfc_get_charlen ();
3851 new_charlen->next = mapping->charlens;
3852 new_charlen->length = gfc_copy_expr (cl->length);
3854 mapping->charlens = new_charlen;
3859 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3860 array variable that can be used as the actual argument for dummy
3861 argument SYM. Add any initialization code to BLOCK. PACKED is as
3862 for gfc_get_nodesc_array_type and DATA points to the first element
3863 in the passed array. */
3866 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3867 gfc_packed packed, tree data)
3872 type = gfc_typenode_for_spec (&sym->ts);
3873 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3874 !sym->attr.target && !sym->attr.pointer
3875 && !sym->attr.proc_pointer);
3877 var = gfc_create_var (type, "ifm");
3878 gfc_add_modify (block, var, fold_convert (type, data));
3884 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3885 and offset of descriptorless array type TYPE given that it has the same
3886 size as DESC. Add any set-up code to BLOCK. */
3889 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3896 offset = gfc_index_zero_node;
3897 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3899 dim = gfc_rank_cst[n];
3900 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3901 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3903 GFC_TYPE_ARRAY_LBOUND (type, n)
3904 = gfc_conv_descriptor_lbound_get (desc, dim);
3905 GFC_TYPE_ARRAY_UBOUND (type, n)
3906 = gfc_conv_descriptor_ubound_get (desc, dim);
3908 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3910 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3911 gfc_array_index_type,
3912 gfc_conv_descriptor_ubound_get (desc, dim),
3913 gfc_conv_descriptor_lbound_get (desc, dim));
3914 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3915 gfc_array_index_type,
3916 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3917 tmp = gfc_evaluate_now (tmp, block);
3918 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3920 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3921 GFC_TYPE_ARRAY_LBOUND (type, n),
3922 GFC_TYPE_ARRAY_STRIDE (type, n));
3923 offset = fold_build2_loc (input_location, MINUS_EXPR,
3924 gfc_array_index_type, offset, tmp);
3926 offset = gfc_evaluate_now (offset, block);
3927 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3931 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3932 in SE. The caller may still use se->expr and se->string_length after
3933 calling this function. */
3936 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3937 gfc_symbol * sym, gfc_se * se,
3940 gfc_interface_sym_mapping *sm;
3944 gfc_symbol *new_sym;
3946 gfc_symtree *new_symtree;
3948 /* Create a new symbol to represent the actual argument. */
3949 new_sym = gfc_new_symbol (sym->name, NULL);
3950 new_sym->ts = sym->ts;
3951 new_sym->as = gfc_copy_array_spec (sym->as);
3952 new_sym->attr.referenced = 1;
3953 new_sym->attr.dimension = sym->attr.dimension;
3954 new_sym->attr.contiguous = sym->attr.contiguous;
3955 new_sym->attr.codimension = sym->attr.codimension;
3956 new_sym->attr.pointer = sym->attr.pointer;
3957 new_sym->attr.allocatable = sym->attr.allocatable;
3958 new_sym->attr.flavor = sym->attr.flavor;
3959 new_sym->attr.function = sym->attr.function;
3961 /* Ensure that the interface is available and that
3962 descriptors are passed for array actual arguments. */
3963 if (sym->attr.flavor == FL_PROCEDURE)
3965 new_sym->formal = expr->symtree->n.sym->formal;
3966 new_sym->attr.always_explicit
3967 = expr->symtree->n.sym->attr.always_explicit;
3970 /* Create a fake symtree for it. */
3972 new_symtree = gfc_new_symtree (&root, sym->name);
3973 new_symtree->n.sym = new_sym;
3974 gcc_assert (new_symtree == root);
3976 /* Create a dummy->actual mapping. */
3977 sm = XCNEW (gfc_interface_sym_mapping);
3978 sm->next = mapping->syms;
3980 sm->new_sym = new_symtree;
3981 sm->expr = gfc_copy_expr (expr);
3984 /* Stabilize the argument's value. */
3985 if (!sym->attr.function && se)
3986 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3988 if (sym->ts.type == BT_CHARACTER)
3990 /* Create a copy of the dummy argument's length. */
3991 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
3992 sm->expr->ts.u.cl = new_sym->ts.u.cl;
3994 /* If the length is specified as "*", record the length that
3995 the caller is passing. We should use the callee's length
3996 in all other cases. */
3997 if (!new_sym->ts.u.cl->length && se)
3999 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4000 new_sym->ts.u.cl->backend_decl = se->string_length;
4007 /* Use the passed value as-is if the argument is a function. */
4008 if (sym->attr.flavor == FL_PROCEDURE)
4011 /* If the argument is a pass-by-value scalar, use the value as is. */
4012 else if (!sym->attr.dimension && sym->attr.value)
4015 /* If the argument is either a string or a pointer to a string,
4016 convert it to a boundless character type. */
4017 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4019 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4020 tmp = build_pointer_type (tmp);
4021 if (sym->attr.pointer)
4022 value = build_fold_indirect_ref_loc (input_location,
4026 value = fold_convert (tmp, value);
4029 /* If the argument is a scalar, a pointer to an array or an allocatable,
4031 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4032 value = build_fold_indirect_ref_loc (input_location,
4035 /* For character(*), use the actual argument's descriptor. */
4036 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4037 value = build_fold_indirect_ref_loc (input_location,
4040 /* If the argument is an array descriptor, use it to determine
4041 information about the actual argument's shape. */
4042 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4043 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4045 /* Get the actual argument's descriptor. */
4046 desc = build_fold_indirect_ref_loc (input_location,
4049 /* Create the replacement variable. */
4050 tmp = gfc_conv_descriptor_data_get (desc);
4051 value = gfc_get_interface_mapping_array (&se->pre, sym,
4054 /* Use DESC to work out the upper bounds, strides and offset. */
4055 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4058 /* Otherwise we have a packed array. */
4059 value = gfc_get_interface_mapping_array (&se->pre, sym,
4060 PACKED_FULL, se->expr);
4062 new_sym->backend_decl = value;
4066 /* Called once all dummy argument mappings have been added to MAPPING,
4067 but before the mapping is used to evaluate expressions. Pre-evaluate
4068 the length of each argument, adding any initialization code to PRE and
4069 any finalization code to POST. */
4072 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4073 stmtblock_t * pre, stmtblock_t * post)
4075 gfc_interface_sym_mapping *sym;
4079 for (sym = mapping->syms; sym; sym = sym->next)
4080 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4081 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4083 expr = sym->new_sym->n.sym->ts.u.cl->length;
4084 gfc_apply_interface_mapping_to_expr (mapping, expr);
4085 gfc_init_se (&se, NULL);
4086 gfc_conv_expr (&se, expr);
4087 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4088 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4089 gfc_add_block_to_block (pre, &se.pre);
4090 gfc_add_block_to_block (post, &se.post);
4092 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4097 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4101 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4102 gfc_constructor_base base)
4105 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4107 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4110 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4111 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4112 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4118 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4122 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4127 for (; ref; ref = ref->next)
4131 for (n = 0; n < ref->u.ar.dimen; n++)
4133 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4134 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4135 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4143 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4144 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4150 /* Convert intrinsic function calls into result expressions. */
4153 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4161 arg1 = expr->value.function.actual->expr;
4162 if (expr->value.function.actual->next)
4163 arg2 = expr->value.function.actual->next->expr;
4167 sym = arg1->symtree->n.sym;
4169 if (sym->attr.dummy)
4174 switch (expr->value.function.isym->id)
4177 /* TODO figure out why this condition is necessary. */
4178 if (sym->attr.function
4179 && (arg1->ts.u.cl->length == NULL
4180 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4181 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4184 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4187 case GFC_ISYM_LEN_TRIM:
4188 new_expr = gfc_copy_expr (arg1);
4189 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4194 gfc_replace_expr (arg1, new_expr);
4198 if (!sym->as || sym->as->rank == 0)
4201 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4203 dup = mpz_get_si (arg2->value.integer);
4208 dup = sym->as->rank;
4212 for (; d < dup; d++)
4216 if (!sym->as->upper[d] || !sym->as->lower[d])
4218 gfc_free_expr (new_expr);
4222 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4223 gfc_get_int_expr (gfc_default_integer_kind,
4225 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4227 new_expr = gfc_multiply (new_expr, tmp);
4233 case GFC_ISYM_LBOUND:
4234 case GFC_ISYM_UBOUND:
4235 /* TODO These implementations of lbound and ubound do not limit if
4236 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4238 if (!sym->as || sym->as->rank == 0)
4241 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4242 d = mpz_get_si (arg2->value.integer) - 1;
4246 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4248 if (sym->as->lower[d])
4249 new_expr = gfc_copy_expr (sym->as->lower[d]);
4253 if (sym->as->upper[d])
4254 new_expr = gfc_copy_expr (sym->as->upper[d]);
4262 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4266 gfc_replace_expr (expr, new_expr);
4272 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4273 gfc_interface_mapping * mapping)
4275 gfc_formal_arglist *f;
4276 gfc_actual_arglist *actual;
4278 actual = expr->value.function.actual;
4279 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4281 for (; f && actual; f = f->next, actual = actual->next)
4286 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4289 if (map_expr->symtree->n.sym->attr.dimension)
4294 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4296 for (d = 0; d < as->rank; d++)
4298 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4299 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4302 expr->value.function.esym->as = as;
4305 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4307 expr->value.function.esym->ts.u.cl->length
4308 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4310 gfc_apply_interface_mapping_to_expr (mapping,
4311 expr->value.function.esym->ts.u.cl->length);
4316 /* EXPR is a copy of an expression that appeared in the interface
4317 associated with MAPPING. Walk it recursively looking for references to
4318 dummy arguments that MAPPING maps to actual arguments. Replace each such
4319 reference with a reference to the associated actual argument. */
4322 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4325 gfc_interface_sym_mapping *sym;
4326 gfc_actual_arglist *actual;
4331 /* Copying an expression does not copy its length, so do that here. */
4332 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4334 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4335 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4338 /* Apply the mapping to any references. */
4339 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4341 /* ...and to the expression's symbol, if it has one. */
4342 /* TODO Find out why the condition on expr->symtree had to be moved into
4343 the loop rather than being outside it, as originally. */
4344 for (sym = mapping->syms; sym; sym = sym->next)
4345 if (expr->symtree && sym->old == expr->symtree->n.sym)
4347 if (sym->new_sym->n.sym->backend_decl)
4348 expr->symtree = sym->new_sym;
4350 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4353 /* ...and to subexpressions in expr->value. */
4354 switch (expr->expr_type)
4359 case EXPR_SUBSTRING:
4363 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4364 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4368 for (actual = expr->value.function.actual; actual; actual = actual->next)
4369 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4371 if (expr->value.function.esym == NULL
4372 && expr->value.function.isym != NULL
4373 && expr->value.function.actual
4374 && expr->value.function.actual->expr
4375 && expr->value.function.actual->expr->symtree
4376 && gfc_map_intrinsic_function (expr, mapping))
4379 for (sym = mapping->syms; sym; sym = sym->next)
4380 if (sym->old == expr->value.function.esym)
4382 expr->value.function.esym = sym->new_sym->n.sym;
4383 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4384 expr->value.function.esym->result = sym->new_sym->n.sym;
4389 case EXPR_STRUCTURE:
4390 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4403 /* Evaluate interface expression EXPR using MAPPING. Store the result
4407 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4408 gfc_se * se, gfc_expr * expr)
4410 expr = gfc_copy_expr (expr);
4411 gfc_apply_interface_mapping_to_expr (mapping, expr);
4412 gfc_conv_expr (se, expr);
4413 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4414 gfc_free_expr (expr);
4418 /* Returns a reference to a temporary array into which a component of
4419 an actual argument derived type array is copied and then returned
4420 after the function call. */
4422 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4423 sym_intent intent, bool formal_ptr)
4431 gfc_array_info *info;
4441 gfc_init_se (&lse, NULL);
4442 gfc_init_se (&rse, NULL);
4444 /* Walk the argument expression. */
4445 rss = gfc_walk_expr (expr);
4447 gcc_assert (rss != gfc_ss_terminator);
4449 /* Initialize the scalarizer. */
4450 gfc_init_loopinfo (&loop);
4451 gfc_add_ss_to_loop (&loop, rss);
4453 /* Calculate the bounds of the scalarization. */
4454 gfc_conv_ss_startstride (&loop);
4456 /* Build an ss for the temporary. */
4457 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4458 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4460 base_type = gfc_typenode_for_spec (&expr->ts);
4461 if (GFC_ARRAY_TYPE_P (base_type)
4462 || GFC_DESCRIPTOR_TYPE_P (base_type))
4463 base_type = gfc_get_element_type (base_type);
4465 if (expr->ts.type == BT_CLASS)
4466 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4468 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4469 ? expr->ts.u.cl->backend_decl
4473 parmse->string_length = loop.temp_ss->info->string_length;
4475 /* Associate the SS with the loop. */
4476 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4478 /* Setup the scalarizing loops. */
4479 gfc_conv_loop_setup (&loop, &expr->where);
4481 /* Pass the temporary descriptor back to the caller. */
4482 info = &loop.temp_ss->info->data.array;
4483 parmse->expr = info->descriptor;
4485 /* Setup the gfc_se structures. */
4486 gfc_copy_loopinfo_to_se (&lse, &loop);
4487 gfc_copy_loopinfo_to_se (&rse, &loop);
4490 lse.ss = loop.temp_ss;
4491 gfc_mark_ss_chain_used (rss, 1);
4492 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4494 /* Start the scalarized loop body. */
4495 gfc_start_scalarized_body (&loop, &body);
4497 /* Translate the expression. */
4498 gfc_conv_expr (&rse, expr);
4500 /* Reset the offset for the function call since the loop
4501 is zero based on the data pointer. Note that the temp
4502 comes first in the loop chain since it is added second. */
4503 if (gfc_is_class_array_function (expr))
4505 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4506 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4507 gfc_index_zero_node);
4510 gfc_conv_tmp_array_ref (&lse);
4512 if (intent != INTENT_OUT)
4514 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4515 gfc_add_expr_to_block (&body, tmp);
4516 gcc_assert (rse.ss == gfc_ss_terminator);
4517 gfc_trans_scalarizing_loops (&loop, &body);
4521 /* Make sure that the temporary declaration survives by merging
4522 all the loop declarations into the current context. */
4523 for (n = 0; n < loop.dimen; n++)
4525 gfc_merge_block_scope (&body);
4526 body = loop.code[loop.order[n]];
4528 gfc_merge_block_scope (&body);
4531 /* Add the post block after the second loop, so that any
4532 freeing of allocated memory is done at the right time. */
4533 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4535 /**********Copy the temporary back again.*********/
4537 gfc_init_se (&lse, NULL);
4538 gfc_init_se (&rse, NULL);
4540 /* Walk the argument expression. */
4541 lss = gfc_walk_expr (expr);
4542 rse.ss = loop.temp_ss;
4545 /* Initialize the scalarizer. */
4546 gfc_init_loopinfo (&loop2);
4547 gfc_add_ss_to_loop (&loop2, lss);
4549 dimen = rse.ss->dimen;
4551 /* Skip the write-out loop for this case. */
4552 if (gfc_is_class_array_function (expr))
4553 goto class_array_fcn;
4555 /* Calculate the bounds of the scalarization. */
4556 gfc_conv_ss_startstride (&loop2);
4558 /* Setup the scalarizing loops. */
4559 gfc_conv_loop_setup (&loop2, &expr->where);
4561 gfc_copy_loopinfo_to_se (&lse, &loop2);
4562 gfc_copy_loopinfo_to_se (&rse, &loop2);
4564 gfc_mark_ss_chain_used (lss, 1);
4565 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4567 /* Declare the variable to hold the temporary offset and start the
4568 scalarized loop body. */
4569 offset = gfc_create_var (gfc_array_index_type, NULL);
4570 gfc_start_scalarized_body (&loop2, &body);
4572 /* Build the offsets for the temporary from the loop variables. The
4573 temporary array has lbounds of zero and strides of one in all
4574 dimensions, so this is very simple. The offset is only computed
4575 outside the innermost loop, so the overall transfer could be
4576 optimized further. */
4577 info = &rse.ss->info->data.array;
4579 tmp_index = gfc_index_zero_node;
4580 for (n = dimen - 1; n > 0; n--)
4583 tmp = rse.loop->loopvar[n];
4584 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4585 tmp, rse.loop->from[n]);
4586 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4589 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4590 gfc_array_index_type,
4591 rse.loop->to[n-1], rse.loop->from[n-1]);
4592 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4593 gfc_array_index_type,
4594 tmp_str, gfc_index_one_node);
4596 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4597 gfc_array_index_type, tmp, tmp_str);
4600 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4601 gfc_array_index_type,
4602 tmp_index, rse.loop->from[0]);
4603 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4605 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4606 gfc_array_index_type,
4607 rse.loop->loopvar[0], offset);
4609 /* Now use the offset for the reference. */
4610 tmp = build_fold_indirect_ref_loc (input_location,
4612 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4614 if (expr->ts.type == BT_CHARACTER)
4615 rse.string_length = expr->ts.u.cl->backend_decl;
4617 gfc_conv_expr (&lse, expr);
4619 gcc_assert (lse.ss == gfc_ss_terminator);
4621 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4622 gfc_add_expr_to_block (&body, tmp);
4624 /* Generate the copying loops. */
4625 gfc_trans_scalarizing_loops (&loop2, &body);
4627 /* Wrap the whole thing up by adding the second loop to the post-block
4628 and following it by the post-block of the first loop. In this way,
4629 if the temporary needs freeing, it is done after use! */
4630 if (intent != INTENT_IN)
4632 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4633 gfc_add_block_to_block (&parmse->post, &loop2.post);
4638 gfc_add_block_to_block (&parmse->post, &loop.post);
4640 gfc_cleanup_loop (&loop);
4641 gfc_cleanup_loop (&loop2);
4643 /* Pass the string length to the argument expression. */
4644 if (expr->ts.type == BT_CHARACTER)
4645 parmse->string_length = expr->ts.u.cl->backend_decl;
4647 /* Determine the offset for pointer formal arguments and set the
4651 size = gfc_index_one_node;
4652 offset = gfc_index_zero_node;
4653 for (n = 0; n < dimen; n++)
4655 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4657 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4658 gfc_array_index_type, tmp,
4659 gfc_index_one_node);
4660 gfc_conv_descriptor_ubound_set (&parmse->pre,
4664 gfc_conv_descriptor_lbound_set (&parmse->pre,
4667 gfc_index_one_node);
4668 size = gfc_evaluate_now (size, &parmse->pre);
4669 offset = fold_build2_loc (input_location, MINUS_EXPR,
4670 gfc_array_index_type,
4672 offset = gfc_evaluate_now (offset, &parmse->pre);
4673 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4674 gfc_array_index_type,
4675 rse.loop->to[n], rse.loop->from[n]);
4676 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4677 gfc_array_index_type,
4678 tmp, gfc_index_one_node);
4679 size = fold_build2_loc (input_location, MULT_EXPR,
4680 gfc_array_index_type, size, tmp);
4683 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4687 /* We want either the address for the data or the address of the descriptor,
4688 depending on the mode of passing array arguments. */
4690 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4692 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4698 /* Generate the code for argument list functions. */
4701 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4703 /* Pass by value for g77 %VAL(arg), pass the address
4704 indirectly for %LOC, else by reference. Thus %REF
4705 is a "do-nothing" and %LOC is the same as an F95
4707 if (strncmp (name, "%VAL", 4) == 0)
4708 gfc_conv_expr (se, expr);
4709 else if (strncmp (name, "%LOC", 4) == 0)
4711 gfc_conv_expr_reference (se, expr);
4712 se->expr = gfc_build_addr_expr (NULL, se->expr);
4714 else if (strncmp (name, "%REF", 4) == 0)
4715 gfc_conv_expr_reference (se, expr);
4717 gfc_error ("Unknown argument list function at %L", &expr->where);
4721 /* This function tells whether the middle-end representation of the expression
4722 E given as input may point to data otherwise accessible through a variable
4724 It is assumed that the only expressions that may alias are variables,
4725 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4727 This function is used to decide whether freeing an expression's allocatable
4728 components is safe or should be avoided.
4730 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4731 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4732 is necessary because for array constructors, aliasing depends on how
4734 - If E is an array constructor used as argument to an elemental procedure,
4735 the array, which is generated through shallow copy by the scalarizer,
4736 is used directly and can alias the expressions it was copied from.
4737 - If E is an array constructor used as argument to a non-elemental
4738 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4739 the array as in the previous case, but then that array is used
4740 to initialize a new descriptor through deep copy. There is no alias
4741 possible in that case.
4742 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4746 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4750 if (e->expr_type == EXPR_VARIABLE)
4752 else if (e->expr_type == EXPR_FUNCTION)
4754 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4756 if (proc_ifc->result != NULL
4757 && ((proc_ifc->result->ts.type == BT_CLASS
4758 && proc_ifc->result->ts.u.derived->attr.is_class
4759 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4760 || proc_ifc->result->attr.pointer))
4765 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4768 for (c = gfc_constructor_first (e->value.constructor);
4769 c; c = gfc_constructor_next (c))
4771 && expr_may_alias_variables (c->expr, array_may_alias))
4778 /* Generate code for a procedure call. Note can return se->post != NULL.
4779 If se->direct_byref is set then se->expr contains the return parameter.
4780 Return nonzero, if the call has alternate specifiers.
4781 'expr' is only needed for procedure pointer components. */
4784 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4785 gfc_actual_arglist * args, gfc_expr * expr,
4786 vec<tree, va_gc> *append_args)
4788 gfc_interface_mapping mapping;
4789 vec<tree, va_gc> *arglist;
4790 vec<tree, va_gc> *retargs;
4794 gfc_array_info *info;
4801 vec<tree, va_gc> *stringargs;
4802 vec<tree, va_gc> *optionalargs;
4804 gfc_formal_arglist *formal;
4805 gfc_actual_arglist *arg;
4806 int has_alternate_specifier = 0;
4807 bool need_interface_mapping;
4815 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4816 gfc_component *comp = NULL;
4823 optionalargs = NULL;
4828 comp = gfc_get_proc_ptr_comp (expr);
4830 bool elemental_proc = (comp
4831 && comp->ts.interface
4832 && comp->ts.interface->attr.elemental)
4833 || (comp && comp->attr.elemental)
4834 || sym->attr.elemental;
4838 if (!elemental_proc)
4840 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4841 if (se->ss->info->useflags)
4843 gcc_assert ((!comp && gfc_return_by_reference (sym)
4844 && sym->result->attr.dimension)
4845 || (comp && comp->attr.dimension)
4846 || gfc_is_class_array_function (expr));
4847 gcc_assert (se->loop != NULL);
4848 /* Access the previously obtained result. */
4849 gfc_conv_tmp_array_ref (se);
4853 info = &se->ss->info->data.array;
4858 gfc_init_block (&post);
4859 gfc_init_interface_mapping (&mapping);
4862 formal = gfc_sym_get_dummy_args (sym);
4863 need_interface_mapping = sym->attr.dimension ||
4864 (sym->ts.type == BT_CHARACTER
4865 && sym->ts.u.cl->length
4866 && sym->ts.u.cl->length->expr_type
4871 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4872 need_interface_mapping = comp->attr.dimension ||
4873 (comp->ts.type == BT_CHARACTER
4874 && comp->ts.u.cl->length
4875 && comp->ts.u.cl->length->expr_type
4879 base_object = NULL_TREE;
4880 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4881 is the third and fourth argument to such a function call a value
4882 denoting the number of elements to copy (i.e., most of the time the
4883 length of a deferred length string). */
4884 ulim_copy = (formal == NULL)
4885 && UNLIMITED_POLY (sym)
4886 && comp && (strcmp ("_copy", comp->name) == 0);
4888 /* Evaluate the arguments. */
4889 for (arg = args, argc = 0; arg != NULL;
4890 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4892 bool finalized = false;
4895 fsym = formal ? formal->sym : NULL;
4896 parm_kind = MISSING;
4898 /* If the procedure requires an explicit interface, the actual
4899 argument is passed according to the corresponding formal
4900 argument. If the corresponding formal argument is a POINTER,
4901 ALLOCATABLE or assumed shape, we do not use g77's calling
4902 convention, and pass the address of the array descriptor
4903 instead. Otherwise we use g77's calling convention, in other words
4904 pass the array data pointer without descriptor. */
4905 bool nodesc_arg = fsym != NULL
4906 && !(fsym->attr.pointer || fsym->attr.allocatable)
4908 && fsym->as->type != AS_ASSUMED_SHAPE
4909 && fsym->as->type != AS_ASSUMED_RANK;
4911 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4913 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4915 /* Class array expressions are sometimes coming completely unadorned
4916 with either arrayspec or _data component. Correct that here.
4917 OOP-TODO: Move this to the frontend. */
4918 if (e && e->expr_type == EXPR_VARIABLE
4920 && e->ts.type == BT_CLASS
4921 && (CLASS_DATA (e)->attr.codimension
4922 || CLASS_DATA (e)->attr.dimension))
4924 gfc_typespec temp_ts = e->ts;
4925 gfc_add_class_array_ref (e);
4931 if (se->ignore_optional)
4933 /* Some intrinsics have already been resolved to the correct
4937 else if (arg->label)
4939 has_alternate_specifier = 1;
4944 gfc_init_se (&parmse, NULL);
4946 /* For scalar arguments with VALUE attribute which are passed by
4947 value, pass "0" and a hidden argument gives the optional
4949 if (fsym && fsym->attr.optional && fsym->attr.value
4950 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4951 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4953 parmse.expr = fold_convert (gfc_sym_type (fsym),
4955 vec_safe_push (optionalargs, boolean_false_node);
4959 /* Pass a NULL pointer for an absent arg. */
4960 parmse.expr = null_pointer_node;
4961 if (arg->missing_arg_type == BT_CHARACTER)
4962 parmse.string_length = build_int_cst (gfc_charlen_type_node,
4967 else if (arg->expr->expr_type == EXPR_NULL
4968 && fsym && !fsym->attr.pointer
4969 && (fsym->ts.type != BT_CLASS
4970 || !CLASS_DATA (fsym)->attr.class_pointer))
4972 /* Pass a NULL pointer to denote an absent arg. */
4973 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4974 && (fsym->ts.type != BT_CLASS
4975 || !CLASS_DATA (fsym)->attr.allocatable));
4976 gfc_init_se (&parmse, NULL);
4977 parmse.expr = null_pointer_node;
4978 if (arg->missing_arg_type == BT_CHARACTER)
4979 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4981 else if (fsym && fsym->ts.type == BT_CLASS
4982 && e->ts.type == BT_DERIVED)
4984 /* The derived type needs to be converted to a temporary
4986 gfc_init_se (&parmse, se);
4987 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4989 && e->expr_type == EXPR_VARIABLE
4990 && e->symtree->n.sym->attr.optional,
4991 CLASS_DATA (fsym)->attr.class_pointer
4992 || CLASS_DATA (fsym)->attr.allocatable);
4994 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4996 /* The intrinsic type needs to be converted to a temporary
4997 CLASS object for the unlimited polymorphic formal. */
4998 gfc_init_se (&parmse, se);
4999 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5001 else if (se->ss && se->ss->info->useflags)
5007 /* An elemental function inside a scalarized loop. */
5008 gfc_init_se (&parmse, se);
5009 parm_kind = ELEMENTAL;
5011 /* When no fsym is present, ulim_copy is set and this is a third or
5012 fourth argument, use call-by-value instead of by reference to
5013 hand the length properties to the copy routine (i.e., most of the
5014 time this will be a call to a __copy_character_* routine where the
5015 third and fourth arguments are the lengths of a deferred length
5017 if ((fsym && fsym->attr.value)
5018 || (ulim_copy && (argc == 2 || argc == 3)))
5019 gfc_conv_expr (&parmse, e);
5021 gfc_conv_expr_reference (&parmse, e);
5023 if (e->ts.type == BT_CHARACTER && !e->rank
5024 && e->expr_type == EXPR_FUNCTION)
5025 parmse.expr = build_fold_indirect_ref_loc (input_location,
5028 if (fsym && fsym->ts.type == BT_DERIVED
5029 && gfc_is_class_container_ref (e))
5031 parmse.expr = gfc_class_data_get (parmse.expr);
5033 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5034 && e->symtree->n.sym->attr.optional)
5036 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5037 parmse.expr = build3_loc (input_location, COND_EXPR,
5038 TREE_TYPE (parmse.expr),
5040 fold_convert (TREE_TYPE (parmse.expr),
5041 null_pointer_node));
5045 /* If we are passing an absent array as optional dummy to an
5046 elemental procedure, make sure that we pass NULL when the data
5047 pointer is NULL. We need this extra conditional because of
5048 scalarization which passes arrays elements to the procedure,
5049 ignoring the fact that the array can be absent/unallocated/... */
5050 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5052 tree descriptor_data;
5054 descriptor_data = ss->info->data.array.data;
5055 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5057 fold_convert (TREE_TYPE (descriptor_data),
5058 null_pointer_node));
5060 = fold_build3_loc (input_location, COND_EXPR,
5061 TREE_TYPE (parmse.expr),
5062 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5063 fold_convert (TREE_TYPE (parmse.expr),
5068 /* The scalarizer does not repackage the reference to a class
5069 array - instead it returns a pointer to the data element. */
5070 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5071 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5072 fsym->attr.intent != INTENT_IN
5073 && (CLASS_DATA (fsym)->attr.class_pointer
5074 || CLASS_DATA (fsym)->attr.allocatable),
5076 && e->expr_type == EXPR_VARIABLE
5077 && e->symtree->n.sym->attr.optional,
5078 CLASS_DATA (fsym)->attr.class_pointer
5079 || CLASS_DATA (fsym)->attr.allocatable);
5086 gfc_init_se (&parmse, NULL);
5088 /* Check whether the expression is a scalar or not; we cannot use
5089 e->rank as it can be nonzero for functions arguments. */
5090 argss = gfc_walk_expr (e);
5091 scalar = argss == gfc_ss_terminator;
5093 gfc_free_ss_chain (argss);
5095 /* Special handling for passing scalar polymorphic coarrays;
5096 otherwise one passes "class->_data.data" instead of "&class". */
5097 if (e->rank == 0 && e->ts.type == BT_CLASS
5098 && fsym && fsym->ts.type == BT_CLASS
5099 && CLASS_DATA (fsym)->attr.codimension
5100 && !CLASS_DATA (fsym)->attr.dimension)
5102 gfc_add_class_array_ref (e);
5103 parmse.want_coarray = 1;
5107 /* A scalar or transformational function. */
5110 if (e->expr_type == EXPR_VARIABLE
5111 && e->symtree->n.sym->attr.cray_pointee
5112 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5114 /* The Cray pointer needs to be converted to a pointer to
5115 a type given by the expression. */
5116 gfc_conv_expr (&parmse, e);
5117 type = build_pointer_type (TREE_TYPE (parmse.expr));
5118 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5119 parmse.expr = convert (type, tmp);
5121 else if (fsym && fsym->attr.value)
5123 if (fsym->ts.type == BT_CHARACTER
5124 && fsym->ts.is_c_interop
5125 && fsym->ns->proc_name != NULL
5126 && fsym->ns->proc_name->attr.is_bind_c)
5129 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5130 if (parmse.expr == NULL)
5131 gfc_conv_expr (&parmse, e);
5135 gfc_conv_expr (&parmse, e);
5136 if (fsym->attr.optional
5137 && fsym->ts.type != BT_CLASS
5138 && fsym->ts.type != BT_DERIVED)
5140 if (e->expr_type != EXPR_VARIABLE
5141 || !e->symtree->n.sym->attr.optional
5143 vec_safe_push (optionalargs, boolean_true_node);
5146 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5147 if (!e->symtree->n.sym->attr.value)
5149 = fold_build3_loc (input_location, COND_EXPR,
5150 TREE_TYPE (parmse.expr),
5152 fold_convert (TREE_TYPE (parmse.expr),
5153 integer_zero_node));
5155 vec_safe_push (optionalargs, tmp);
5160 else if (arg->name && arg->name[0] == '%')
5161 /* Argument list functions %VAL, %LOC and %REF are signalled
5162 through arg->name. */
5163 conv_arglist_function (&parmse, arg->expr, arg->name);
5164 else if ((e->expr_type == EXPR_FUNCTION)
5165 && ((e->value.function.esym
5166 && e->value.function.esym->result->attr.pointer)
5167 || (!e->value.function.esym
5168 && e->symtree->n.sym->attr.pointer))
5169 && fsym && fsym->attr.target)
5171 gfc_conv_expr (&parmse, e);
5172 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5174 else if (e->expr_type == EXPR_FUNCTION
5175 && e->symtree->n.sym->result
5176 && e->symtree->n.sym->result != e->symtree->n.sym
5177 && e->symtree->n.sym->result->attr.proc_pointer)
5179 /* Functions returning procedure pointers. */
5180 gfc_conv_expr (&parmse, e);
5181 if (fsym && fsym->attr.proc_pointer)
5182 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5186 if (e->ts.type == BT_CLASS && fsym
5187 && fsym->ts.type == BT_CLASS
5188 && (!CLASS_DATA (fsym)->as
5189 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5190 && CLASS_DATA (e)->attr.codimension)
5192 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5193 gcc_assert (!CLASS_DATA (fsym)->as);
5194 gfc_add_class_array_ref (e);
5195 parmse.want_coarray = 1;
5196 gfc_conv_expr_reference (&parmse, e);
5197 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5199 && e->expr_type == EXPR_VARIABLE);
5201 else if (e->ts.type == BT_CLASS && fsym
5202 && fsym->ts.type == BT_CLASS
5203 && !CLASS_DATA (fsym)->as
5204 && !CLASS_DATA (e)->as
5205 && strcmp (fsym->ts.u.derived->name,
5206 e->ts.u.derived->name))
5208 type = gfc_typenode_for_spec (&fsym->ts);
5209 var = gfc_create_var (type, fsym->name);
5210 gfc_conv_expr (&parmse, e);
5211 if (fsym->attr.optional
5212 && e->expr_type == EXPR_VARIABLE
5213 && e->symtree->n.sym->attr.optional)
5217 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5218 cond = fold_build2_loc (input_location, NE_EXPR,
5219 logical_type_node, tmp,
5220 fold_convert (TREE_TYPE (tmp),
5221 null_pointer_node));
5222 gfc_start_block (&block);
5223 gfc_add_modify (&block, var,
5224 fold_build1_loc (input_location,
5226 type, parmse.expr));
5227 gfc_add_expr_to_block (&parmse.pre,
5228 fold_build3_loc (input_location,
5229 COND_EXPR, void_type_node,
5230 cond, gfc_finish_block (&block),
5231 build_empty_stmt (input_location)));
5232 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5233 parmse.expr = build3_loc (input_location, COND_EXPR,
5234 TREE_TYPE (parmse.expr),
5236 fold_convert (TREE_TYPE (parmse.expr),
5237 null_pointer_node));
5241 /* Since the internal representation of unlimited
5242 polymorphic expressions includes an extra field
5243 that other class objects do not, a cast to the
5244 formal type does not work. */
5245 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5249 /* Set the _data field. */
5250 tmp = gfc_class_data_get (var);
5251 efield = fold_convert (TREE_TYPE (tmp),
5252 gfc_class_data_get (parmse.expr));
5253 gfc_add_modify (&parmse.pre, tmp, efield);
5255 /* Set the _vptr field. */
5256 tmp = gfc_class_vptr_get (var);
5257 efield = fold_convert (TREE_TYPE (tmp),
5258 gfc_class_vptr_get (parmse.expr));
5259 gfc_add_modify (&parmse.pre, tmp, efield);
5261 /* Set the _len field. */
5262 tmp = gfc_class_len_get (var);
5263 gfc_add_modify (&parmse.pre, tmp,
5264 build_int_cst (TREE_TYPE (tmp), 0));
5268 tmp = fold_build1_loc (input_location,
5271 gfc_add_modify (&parmse.pre, var, tmp);
5274 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5278 gfc_conv_expr_reference (&parmse, e);
5280 /* Catch base objects that are not variables. */
5281 if (e->ts.type == BT_CLASS
5282 && e->expr_type != EXPR_VARIABLE
5283 && expr && e == expr->base_expr)
5284 base_object = build_fold_indirect_ref_loc (input_location,
5287 /* A class array element needs converting back to be a
5288 class object, if the formal argument is a class object. */
5289 if (fsym && fsym->ts.type == BT_CLASS
5290 && e->ts.type == BT_CLASS
5291 && ((CLASS_DATA (fsym)->as
5292 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5293 || CLASS_DATA (e)->attr.dimension))
5294 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5295 fsym->attr.intent != INTENT_IN
5296 && (CLASS_DATA (fsym)->attr.class_pointer
5297 || CLASS_DATA (fsym)->attr.allocatable),
5299 && e->expr_type == EXPR_VARIABLE
5300 && e->symtree->n.sym->attr.optional,
5301 CLASS_DATA (fsym)->attr.class_pointer
5302 || CLASS_DATA (fsym)->attr.allocatable);
5304 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5305 allocated on entry, it must be deallocated. */
5306 if (fsym && fsym->attr.intent == INTENT_OUT
5307 && (fsym->attr.allocatable
5308 || (fsym->ts.type == BT_CLASS
5309 && CLASS_DATA (fsym)->attr.allocatable)))
5314 gfc_init_block (&block);
5316 if (e->ts.type == BT_CLASS)
5317 ptr = gfc_class_data_get (ptr);
5319 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5322 gfc_add_expr_to_block (&block, tmp);
5323 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5324 void_type_node, ptr,
5326 gfc_add_expr_to_block (&block, tmp);
5328 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5330 gfc_add_modify (&block, ptr,
5331 fold_convert (TREE_TYPE (ptr),
5332 null_pointer_node));
5333 gfc_add_expr_to_block (&block, tmp);
5335 else if (fsym->ts.type == BT_CLASS)
5338 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5339 tmp = gfc_get_symbol_decl (vtab);
5340 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5341 ptr = gfc_class_vptr_get (parmse.expr);
5342 gfc_add_modify (&block, ptr,
5343 fold_convert (TREE_TYPE (ptr), tmp));
5344 gfc_add_expr_to_block (&block, tmp);
5347 if (fsym->attr.optional
5348 && e->expr_type == EXPR_VARIABLE
5349 && e->symtree->n.sym->attr.optional)
5351 tmp = fold_build3_loc (input_location, COND_EXPR,
5353 gfc_conv_expr_present (e->symtree->n.sym),
5354 gfc_finish_block (&block),
5355 build_empty_stmt (input_location));
5358 tmp = gfc_finish_block (&block);
5360 gfc_add_expr_to_block (&se->pre, tmp);
5363 if (fsym && (fsym->ts.type == BT_DERIVED
5364 || fsym->ts.type == BT_ASSUMED)
5365 && e->ts.type == BT_CLASS
5366 && !CLASS_DATA (e)->attr.dimension
5367 && !CLASS_DATA (e)->attr.codimension)
5369 parmse.expr = gfc_class_data_get (parmse.expr);
5370 /* The result is a class temporary, whose _data component
5371 must be freed to avoid a memory leak. */
5372 if (e->expr_type == EXPR_FUNCTION
5373 && CLASS_DATA (e)->attr.allocatable)
5379 /* Borrow the function symbol to make a call to
5380 gfc_add_finalizer_call and then restore it. */
5381 tmp = e->symtree->n.sym->backend_decl;
5382 e->symtree->n.sym->backend_decl
5383 = TREE_OPERAND (parmse.expr, 0);
5384 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5385 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5386 finalized = gfc_add_finalizer_call (&parmse.post,
5388 gfc_free_expr (var);
5389 e->symtree->n.sym->backend_decl = tmp;
5390 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5392 /* Then free the class _data. */
5393 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5394 tmp = fold_build2_loc (input_location, NE_EXPR,
5397 tmp = build3_v (COND_EXPR, tmp,
5398 gfc_call_free (parmse.expr),
5399 build_empty_stmt (input_location));
5400 gfc_add_expr_to_block (&parmse.post, tmp);
5401 gfc_add_modify (&parmse.post, parmse.expr, zero);
5405 /* Wrap scalar variable in a descriptor. We need to convert
5406 the address of a pointer back to the pointer itself before,
5407 we can assign it to the data field. */
5409 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5410 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5413 if (TREE_CODE (tmp) == ADDR_EXPR)
5414 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5415 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5417 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5420 else if (fsym && e->expr_type != EXPR_NULL
5421 && ((fsym->attr.pointer
5422 && fsym->attr.flavor != FL_PROCEDURE)
5423 || (fsym->attr.proc_pointer
5424 && !(e->expr_type == EXPR_VARIABLE
5425 && e->symtree->n.sym->attr.dummy))
5426 || (fsym->attr.proc_pointer
5427 && e->expr_type == EXPR_VARIABLE
5428 && gfc_is_proc_ptr_comp (e))
5429 || (fsym->attr.allocatable
5430 && fsym->attr.flavor != FL_PROCEDURE)))
5432 /* Scalar pointer dummy args require an extra level of
5433 indirection. The null pointer already contains
5434 this level of indirection. */
5435 parm_kind = SCALAR_POINTER;
5436 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5440 else if (e->ts.type == BT_CLASS
5441 && fsym && fsym->ts.type == BT_CLASS
5442 && (CLASS_DATA (fsym)->attr.dimension
5443 || CLASS_DATA (fsym)->attr.codimension))
5445 /* Pass a class array. */
5446 parmse.use_offset = 1;
5447 gfc_conv_expr_descriptor (&parmse, e);
5449 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5450 allocated on entry, it must be deallocated. */
5451 if (fsym->attr.intent == INTENT_OUT
5452 && CLASS_DATA (fsym)->attr.allocatable)
5457 gfc_init_block (&block);
5459 ptr = gfc_class_data_get (ptr);
5461 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5462 NULL_TREE, NULL_TREE,
5464 GFC_CAF_COARRAY_NOCOARRAY);
5465 gfc_add_expr_to_block (&block, tmp);
5466 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5467 void_type_node, ptr,
5469 gfc_add_expr_to_block (&block, tmp);
5470 gfc_reset_vptr (&block, e);
5472 if (fsym->attr.optional
5473 && e->expr_type == EXPR_VARIABLE
5475 || (e->ref->type == REF_ARRAY
5476 && e->ref->u.ar.type != AR_FULL))
5477 && e->symtree->n.sym->attr.optional)
5479 tmp = fold_build3_loc (input_location, COND_EXPR,
5481 gfc_conv_expr_present (e->symtree->n.sym),
5482 gfc_finish_block (&block),
5483 build_empty_stmt (input_location));
5486 tmp = gfc_finish_block (&block);
5488 gfc_add_expr_to_block (&se->pre, tmp);
5491 /* The conversion does not repackage the reference to a class
5492 array - _data descriptor. */
5493 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5494 fsym->attr.intent != INTENT_IN
5495 && (CLASS_DATA (fsym)->attr.class_pointer
5496 || CLASS_DATA (fsym)->attr.allocatable),
5498 && e->expr_type == EXPR_VARIABLE
5499 && e->symtree->n.sym->attr.optional,
5500 CLASS_DATA (fsym)->attr.class_pointer
5501 || CLASS_DATA (fsym)->attr.allocatable);
5505 /* If the argument is a function call that may not create
5506 a temporary for the result, we have to check that we
5507 can do it, i.e. that there is no alias between this
5508 argument and another one. */
5509 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5515 intent = fsym->attr.intent;
5517 intent = INTENT_UNKNOWN;
5519 if (gfc_check_fncall_dependency (e, intent, sym, args,
5521 parmse.force_tmp = 1;
5523 iarg = e->value.function.actual->expr;
5525 /* Temporary needed if aliasing due to host association. */
5526 if (sym->attr.contained
5528 && !sym->attr.implicit_pure
5529 && !sym->attr.use_assoc
5530 && iarg->expr_type == EXPR_VARIABLE
5531 && sym->ns == iarg->symtree->n.sym->ns)
5532 parmse.force_tmp = 1;
5534 /* Ditto within module. */
5535 if (sym->attr.use_assoc
5537 && !sym->attr.implicit_pure
5538 && iarg->expr_type == EXPR_VARIABLE
5539 && sym->module == iarg->symtree->n.sym->module)
5540 parmse.force_tmp = 1;
5543 if (e->expr_type == EXPR_VARIABLE
5544 && is_subref_array (e)
5545 && !(fsym && fsym->attr.pointer))
5546 /* The actual argument is a component reference to an
5547 array of derived types. In this case, the argument
5548 is converted to a temporary, which is passed and then
5549 written back after the procedure call. */
5550 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5551 fsym ? fsym->attr.intent : INTENT_INOUT,
5552 fsym && fsym->attr.pointer);
5553 else if (gfc_is_class_array_ref (e, NULL)
5554 && fsym && fsym->ts.type == BT_DERIVED)
5555 /* The actual argument is a component reference to an
5556 array of derived types. In this case, the argument
5557 is converted to a temporary, which is passed and then
5558 written back after the procedure call.
5559 OOP-TODO: Insert code so that if the dynamic type is
5560 the same as the declared type, copy-in/copy-out does
5562 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5563 fsym ? fsym->attr.intent : INTENT_INOUT,
5564 fsym && fsym->attr.pointer);
5566 else if (gfc_is_class_array_function (e)
5567 && fsym && fsym->ts.type == BT_DERIVED)
5568 /* See previous comment. For function actual argument,
5569 the write out is not needed so the intent is set as
5572 e->must_finalize = 1;
5573 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5575 fsym && fsym->attr.pointer);
5578 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5581 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5582 allocated on entry, it must be deallocated. */
5583 if (fsym && fsym->attr.allocatable
5584 && fsym->attr.intent == INTENT_OUT)
5586 if (fsym->ts.type == BT_DERIVED
5587 && fsym->ts.u.derived->attr.alloc_comp)
5589 // deallocate the components first
5590 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5591 parmse.expr, e->rank);
5592 if (tmp != NULL_TREE)
5593 gfc_add_expr_to_block (&se->pre, tmp);
5596 tmp = build_fold_indirect_ref_loc (input_location,
5598 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5599 tmp = gfc_conv_descriptor_data_get (tmp);
5600 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5601 NULL_TREE, NULL_TREE, true,
5603 GFC_CAF_COARRAY_NOCOARRAY);
5604 if (fsym->attr.optional
5605 && e->expr_type == EXPR_VARIABLE
5606 && e->symtree->n.sym->attr.optional)
5607 tmp = fold_build3_loc (input_location, COND_EXPR,
5609 gfc_conv_expr_present (e->symtree->n.sym),
5610 tmp, build_empty_stmt (input_location));
5611 gfc_add_expr_to_block (&se->pre, tmp);
5616 /* The case with fsym->attr.optional is that of a user subroutine
5617 with an interface indicating an optional argument. When we call
5618 an intrinsic subroutine, however, fsym is NULL, but we might still
5619 have an optional argument, so we proceed to the substitution
5621 if (e && (fsym == NULL || fsym->attr.optional))
5623 /* If an optional argument is itself an optional dummy argument,
5624 check its presence and substitute a null if absent. This is
5625 only needed when passing an array to an elemental procedure
5626 as then array elements are accessed - or no NULL pointer is
5627 allowed and a "1" or "0" should be passed if not present.
5628 When passing a non-array-descriptor full array to a
5629 non-array-descriptor dummy, no check is needed. For
5630 array-descriptor actual to array-descriptor dummy, see
5631 PR 41911 for why a check has to be inserted.
5632 fsym == NULL is checked as intrinsics required the descriptor
5633 but do not always set fsym. */
5634 if (e->expr_type == EXPR_VARIABLE
5635 && e->symtree->n.sym->attr.optional
5636 && ((e->rank != 0 && elemental_proc)
5637 || e->representation.length || e->ts.type == BT_CHARACTER
5641 && (fsym->as->type == AS_ASSUMED_SHAPE
5642 || fsym->as->type == AS_ASSUMED_RANK
5643 || fsym->as->type == AS_DEFERRED))))))
5644 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5645 e->representation.length);
5650 /* Obtain the character length of an assumed character length
5651 length procedure from the typespec. */
5652 if (fsym->ts.type == BT_CHARACTER
5653 && parmse.string_length == NULL_TREE
5654 && e->ts.type == BT_PROCEDURE
5655 && e->symtree->n.sym->ts.type == BT_CHARACTER
5656 && e->symtree->n.sym->ts.u.cl->length != NULL
5657 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5659 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5660 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5664 if (fsym && need_interface_mapping && e)
5665 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5667 gfc_add_block_to_block (&se->pre, &parmse.pre);
5668 gfc_add_block_to_block (&post, &parmse.post);
5670 /* Allocated allocatable components of derived types must be
5671 deallocated for non-variable scalars, array arguments to elemental
5672 procedures, and array arguments with descriptor to non-elemental
5673 procedures. As bounds information for descriptorless arrays is no
5674 longer available here, they are dealt with in trans-array.c
5675 (gfc_conv_array_parameter). */
5676 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5677 && e->ts.u.derived->attr.alloc_comp
5678 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5679 && !expr_may_alias_variables (e, elemental_proc))
5682 /* It is known the e returns a structure type with at least one
5683 allocatable component. When e is a function, ensure that the
5684 function is called once only by using a temporary variable. */
5685 if (!DECL_P (parmse.expr))
5686 parmse.expr = gfc_evaluate_now_loc (input_location,
5687 parmse.expr, &se->pre);
5689 if (fsym && fsym->attr.value)
5692 tmp = build_fold_indirect_ref_loc (input_location,
5695 parm_rank = e->rank;
5703 case (SCALAR_POINTER):
5704 tmp = build_fold_indirect_ref_loc (input_location,
5709 if (e->expr_type == EXPR_OP
5710 && e->value.op.op == INTRINSIC_PARENTHESES
5711 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5714 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5715 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5717 gfc_add_expr_to_block (&se->post, local_tmp);
5720 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5722 /* The derived type is passed to gfc_deallocate_alloc_comp.
5723 Therefore, class actuals can handled correctly but derived
5724 types passed to class formals need the _data component. */
5725 tmp = gfc_class_data_get (tmp);
5726 if (!CLASS_DATA (fsym)->attr.dimension)
5727 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5730 if (!finalized && !e->must_finalize)
5732 if ((e->ts.type == BT_CLASS
5733 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
5734 || e->ts.type == BT_DERIVED)
5735 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
5737 else if (e->ts.type == BT_CLASS)
5738 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
5740 gfc_prepend_expr_to_block (&post, tmp);
5744 /* Add argument checking of passing an unallocated/NULL actual to
5745 a nonallocatable/nonpointer dummy. */
5747 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5749 symbol_attribute attr;
5753 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5754 attr = gfc_expr_attr (e);
5756 goto end_pointer_check;
5758 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5759 allocatable to an optional dummy, cf. 12.5.2.12. */
5760 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5761 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5762 goto end_pointer_check;
5766 /* If the actual argument is an optional pointer/allocatable and
5767 the formal argument takes an nonpointer optional value,
5768 it is invalid to pass a non-present argument on, even
5769 though there is no technical reason for this in gfortran.
5770 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5771 tree present, null_ptr, type;
5773 if (attr.allocatable
5774 && (fsym == NULL || !fsym->attr.allocatable))
5775 msg = xasprintf ("Allocatable actual argument '%s' is not "
5776 "allocated or not present",
5777 e->symtree->n.sym->name);
5778 else if (attr.pointer
5779 && (fsym == NULL || !fsym->attr.pointer))
5780 msg = xasprintf ("Pointer actual argument '%s' is not "
5781 "associated or not present",
5782 e->symtree->n.sym->name);
5783 else if (attr.proc_pointer
5784 && (fsym == NULL || !fsym->attr.proc_pointer))
5785 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5786 "associated or not present",
5787 e->symtree->n.sym->name);
5789 goto end_pointer_check;
5791 present = gfc_conv_expr_present (e->symtree->n.sym);
5792 type = TREE_TYPE (present);
5793 present = fold_build2_loc (input_location, EQ_EXPR,
5794 logical_type_node, present,
5796 null_pointer_node));
5797 type = TREE_TYPE (parmse.expr);
5798 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5799 logical_type_node, parmse.expr,
5801 null_pointer_node));
5802 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5803 logical_type_node, present, null_ptr);
5807 if (attr.allocatable
5808 && (fsym == NULL || !fsym->attr.allocatable))
5809 msg = xasprintf ("Allocatable actual argument '%s' is not "
5810 "allocated", e->symtree->n.sym->name);
5811 else if (attr.pointer
5812 && (fsym == NULL || !fsym->attr.pointer))
5813 msg = xasprintf ("Pointer actual argument '%s' is not "
5814 "associated", e->symtree->n.sym->name);
5815 else if (attr.proc_pointer
5816 && (fsym == NULL || !fsym->attr.proc_pointer))
5817 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5818 "associated", e->symtree->n.sym->name);
5820 goto end_pointer_check;
5824 /* If the argument is passed by value, we need to strip the
5826 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5827 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5829 cond = fold_build2_loc (input_location, EQ_EXPR,
5830 logical_type_node, tmp,
5831 fold_convert (TREE_TYPE (tmp),
5832 null_pointer_node));
5835 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5841 /* Deferred length dummies pass the character length by reference
5842 so that the value can be returned. */
5843 if (parmse.string_length && fsym && fsym->ts.deferred)
5845 if (INDIRECT_REF_P (parmse.string_length))
5846 /* In chains of functions/procedure calls the string_length already
5847 is a pointer to the variable holding the length. Therefore
5848 remove the deref on call. */
5849 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5852 tmp = parmse.string_length;
5853 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5854 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5855 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5859 /* Character strings are passed as two parameters, a length and a
5860 pointer - except for Bind(c) which only passes the pointer.
5861 An unlimited polymorphic formal argument likewise does not
5863 if (parmse.string_length != NULL_TREE
5864 && !sym->attr.is_bind_c
5865 && !(fsym && UNLIMITED_POLY (fsym)))
5866 vec_safe_push (stringargs, parmse.string_length);
5868 /* When calling __copy for character expressions to unlimited
5869 polymorphic entities, the dst argument needs a string length. */
5870 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5871 && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
5872 && arg->next && arg->next->expr
5873 && (arg->next->expr->ts.type == BT_DERIVED
5874 || arg->next->expr->ts.type == BT_CLASS)
5875 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5876 vec_safe_push (stringargs, parmse.string_length);
5878 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5879 pass the token and the offset as additional arguments. */
5880 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5881 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5882 && !fsym->attr.allocatable)
5883 || (fsym->ts.type == BT_CLASS
5884 && CLASS_DATA (fsym)->attr.codimension
5885 && !CLASS_DATA (fsym)->attr.allocatable)))
5887 /* Token and offset. */
5888 vec_safe_push (stringargs, null_pointer_node);
5889 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5890 gcc_assert (fsym->attr.optional);
5892 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5893 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5894 && !fsym->attr.allocatable)
5895 || (fsym->ts.type == BT_CLASS
5896 && CLASS_DATA (fsym)->attr.codimension
5897 && !CLASS_DATA (fsym)->attr.allocatable)))
5899 tree caf_decl, caf_type;
5902 caf_decl = gfc_get_tree_for_caf_expr (e);
5903 caf_type = TREE_TYPE (caf_decl);
5905 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5906 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5907 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5908 tmp = gfc_conv_descriptor_token (caf_decl);
5909 else if (DECL_LANG_SPECIFIC (caf_decl)
5910 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5911 tmp = GFC_DECL_TOKEN (caf_decl);
5914 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5915 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5916 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5919 vec_safe_push (stringargs, tmp);
5921 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5922 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5923 offset = build_int_cst (gfc_array_index_type, 0);
5924 else if (DECL_LANG_SPECIFIC (caf_decl)
5925 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5926 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5927 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5928 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5930 offset = build_int_cst (gfc_array_index_type, 0);
5932 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5933 tmp = gfc_conv_descriptor_data_get (caf_decl);
5936 gcc_assert (POINTER_TYPE_P (caf_type));
5940 tmp2 = fsym->ts.type == BT_CLASS
5941 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5942 if ((fsym->ts.type != BT_CLASS
5943 && (fsym->as->type == AS_ASSUMED_SHAPE
5944 || fsym->as->type == AS_ASSUMED_RANK))
5945 || (fsym->ts.type == BT_CLASS
5946 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
5947 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
5949 if (fsym->ts.type == BT_CLASS)
5950 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
5953 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5954 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
5956 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
5957 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5959 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
5960 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5963 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5966 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5967 gfc_array_index_type,
5968 fold_convert (gfc_array_index_type, tmp2),
5969 fold_convert (gfc_array_index_type, tmp));
5970 offset = fold_build2_loc (input_location, PLUS_EXPR,
5971 gfc_array_index_type, offset, tmp);
5973 vec_safe_push (stringargs, offset);
5976 vec_safe_push (arglist, parmse.expr);
5978 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
5982 else if (sym->ts.type == BT_CLASS)
5983 ts = CLASS_DATA (sym)->ts;
5987 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
5988 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
5989 else if (ts.type == BT_CHARACTER)
5991 if (ts.u.cl->length == NULL)
5993 /* Assumed character length results are not allowed by C418 of the 2003
5994 standard and are trapped in resolve.c; except in the case of SPREAD
5995 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5996 we take the character length of the first argument for the result.
5997 For dummies, we have to look through the formal argument list for
5998 this function and use the character length found there.*/
6000 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6001 else if (!sym->attr.dummy)
6002 cl.backend_decl = (*stringargs)[0];
6005 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6006 for (; formal; formal = formal->next)
6007 if (strcmp (formal->sym->name, sym->name) == 0)
6008 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6010 len = cl.backend_decl;
6016 /* Calculate the length of the returned string. */
6017 gfc_init_se (&parmse, NULL);
6018 if (need_interface_mapping)
6019 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6021 gfc_conv_expr (&parmse, ts.u.cl->length);
6022 gfc_add_block_to_block (&se->pre, &parmse.pre);
6023 gfc_add_block_to_block (&se->post, &parmse.post);
6025 /* TODO: It would be better to have the charlens as
6026 gfc_charlen_type_node already when the interface is
6027 created instead of converting it here (see PR 84615). */
6028 tmp = fold_build2_loc (input_location, MAX_EXPR,
6029 gfc_charlen_type_node,
6030 fold_convert (gfc_charlen_type_node, tmp),
6031 build_zero_cst (gfc_charlen_type_node));
6032 cl.backend_decl = tmp;
6035 /* Set up a charlen structure for it. */
6040 len = cl.backend_decl;
6043 byref = (comp && (comp->attr.dimension
6044 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6045 || (!comp && gfc_return_by_reference (sym));
6048 if (se->direct_byref)
6050 /* Sometimes, too much indirection can be applied; e.g. for
6051 function_result = array_valued_recursive_function. */
6052 if (TREE_TYPE (TREE_TYPE (se->expr))
6053 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6054 && GFC_DESCRIPTOR_TYPE_P
6055 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6056 se->expr = build_fold_indirect_ref_loc (input_location,
6059 /* If the lhs of an assignment x = f(..) is allocatable and
6060 f2003 is allowed, we must do the automatic reallocation.
6061 TODO - deal with intrinsics, without using a temporary. */
6062 if (flag_realloc_lhs
6063 && se->ss && se->ss->loop_chain
6064 && se->ss->loop_chain->is_alloc_lhs
6065 && !expr->value.function.isym
6066 && sym->result->as != NULL)
6068 /* Evaluate the bounds of the result, if known. */
6069 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6072 /* Perform the automatic reallocation. */
6073 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6075 gfc_add_expr_to_block (&se->pre, tmp);
6077 /* Pass the temporary as the first argument. */
6078 result = info->descriptor;
6081 result = build_fold_indirect_ref_loc (input_location,
6083 vec_safe_push (retargs, se->expr);
6085 else if (comp && comp->attr.dimension)
6087 gcc_assert (se->loop && info);
6089 /* Set the type of the array. */
6090 tmp = gfc_typenode_for_spec (&comp->ts);
6091 gcc_assert (se->ss->dimen == se->loop->dimen);
6093 /* Evaluate the bounds of the result, if known. */
6094 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6096 /* If the lhs of an assignment x = f(..) is allocatable and
6097 f2003 is allowed, we must not generate the function call
6098 here but should just send back the results of the mapping.
6099 This is signalled by the function ss being flagged. */
6100 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6102 gfc_free_interface_mapping (&mapping);
6103 return has_alternate_specifier;
6106 /* Create a temporary to store the result. In case the function
6107 returns a pointer, the temporary will be a shallow copy and
6108 mustn't be deallocated. */
6109 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6110 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6111 tmp, NULL_TREE, false,
6112 !comp->attr.pointer, callee_alloc,
6113 &se->ss->info->expr->where);
6115 /* Pass the temporary as the first argument. */
6116 result = info->descriptor;
6117 tmp = gfc_build_addr_expr (NULL_TREE, result);
6118 vec_safe_push (retargs, tmp);
6120 else if (!comp && sym->result->attr.dimension)
6122 gcc_assert (se->loop && info);
6124 /* Set the type of the array. */
6125 tmp = gfc_typenode_for_spec (&ts);
6126 gcc_assert (se->ss->dimen == se->loop->dimen);
6128 /* Evaluate the bounds of the result, if known. */
6129 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6131 /* If the lhs of an assignment x = f(..) is allocatable and
6132 f2003 is allowed, we must not generate the function call
6133 here but should just send back the results of the mapping.
6134 This is signalled by the function ss being flagged. */
6135 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6137 gfc_free_interface_mapping (&mapping);
6138 return has_alternate_specifier;
6141 /* Create a temporary to store the result. In case the function
6142 returns a pointer, the temporary will be a shallow copy and
6143 mustn't be deallocated. */
6144 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6145 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6146 tmp, NULL_TREE, false,
6147 !sym->attr.pointer, callee_alloc,
6148 &se->ss->info->expr->where);
6150 /* Pass the temporary as the first argument. */
6151 result = info->descriptor;
6152 tmp = gfc_build_addr_expr (NULL_TREE, result);
6153 vec_safe_push (retargs, tmp);
6155 else if (ts.type == BT_CHARACTER)
6157 /* Pass the string length. */
6158 type = gfc_get_character_type (ts.kind, ts.u.cl);
6159 type = build_pointer_type (type);
6161 /* Emit a DECL_EXPR for the VLA type. */
6162 tmp = TREE_TYPE (type);
6164 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6166 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6167 DECL_ARTIFICIAL (tmp) = 1;
6168 DECL_IGNORED_P (tmp) = 1;
6169 tmp = fold_build1_loc (input_location, DECL_EXPR,
6170 TREE_TYPE (tmp), tmp);
6171 gfc_add_expr_to_block (&se->pre, tmp);
6174 /* Return an address to a char[0:len-1]* temporary for
6175 character pointers. */
6176 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6177 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6179 var = gfc_create_var (type, "pstr");
6181 if ((!comp && sym->attr.allocatable)
6182 || (comp && comp->attr.allocatable))
6184 gfc_add_modify (&se->pre, var,
6185 fold_convert (TREE_TYPE (var),
6186 null_pointer_node));
6187 tmp = gfc_call_free (var);
6188 gfc_add_expr_to_block (&se->post, tmp);
6191 /* Provide an address expression for the function arguments. */
6192 var = gfc_build_addr_expr (NULL_TREE, var);
6195 var = gfc_conv_string_tmp (se, type, len);
6197 vec_safe_push (retargs, var);
6201 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6203 type = gfc_get_complex_type (ts.kind);
6204 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6205 vec_safe_push (retargs, var);
6208 /* Add the string length to the argument list. */
6209 if (ts.type == BT_CHARACTER && ts.deferred)
6213 tmp = gfc_evaluate_now (len, &se->pre);
6214 TREE_STATIC (tmp) = 1;
6215 gfc_add_modify (&se->pre, tmp,
6216 build_int_cst (TREE_TYPE (tmp), 0));
6217 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6218 vec_safe_push (retargs, tmp);
6220 else if (ts.type == BT_CHARACTER)
6221 vec_safe_push (retargs, len);
6223 gfc_free_interface_mapping (&mapping);
6225 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6226 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6227 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6228 vec_safe_reserve (retargs, arglen);
6230 /* Add the return arguments. */
6231 vec_safe_splice (retargs, arglist);
6233 /* Add the hidden present status for optional+value to the arguments. */
6234 vec_safe_splice (retargs, optionalargs);
6236 /* Add the hidden string length parameters to the arguments. */
6237 vec_safe_splice (retargs, stringargs);
6239 /* We may want to append extra arguments here. This is used e.g. for
6240 calls to libgfortran_matmul_??, which need extra information. */
6241 vec_safe_splice (retargs, append_args);
6245 /* Generate the actual call. */
6246 if (base_object == NULL_TREE)
6247 conv_function_val (se, sym, expr);
6249 conv_base_obj_fcn_val (se, base_object, expr);
6251 /* If there are alternate return labels, function type should be
6252 integer. Can't modify the type in place though, since it can be shared
6253 with other functions. For dummy arguments, the typing is done to
6254 this result, even if it has to be repeated for each call. */
6255 if (has_alternate_specifier
6256 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6258 if (!sym->attr.dummy)
6260 TREE_TYPE (sym->backend_decl)
6261 = build_function_type (integer_type_node,
6262 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6263 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6266 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6269 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6270 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6272 /* Allocatable scalar function results must be freed and nullified
6273 after use. This necessitates the creation of a temporary to
6274 hold the result to prevent duplicate calls. */
6275 if (!byref && sym->ts.type != BT_CHARACTER
6276 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6277 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6279 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6280 gfc_add_modify (&se->pre, tmp, se->expr);
6282 tmp = gfc_call_free (tmp);
6283 gfc_add_expr_to_block (&post, tmp);
6284 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6287 /* If we have a pointer function, but we don't want a pointer, e.g.
6290 where f is pointer valued, we have to dereference the result. */
6291 if (!se->want_pointer && !byref
6292 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6293 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6294 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6296 /* f2c calling conventions require a scalar default real function to
6297 return a double precision result. Convert this back to default
6298 real. We only care about the cases that can happen in Fortran 77.
6300 if (flag_f2c && sym->ts.type == BT_REAL
6301 && sym->ts.kind == gfc_default_real_kind
6302 && !sym->attr.always_explicit)
6303 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6305 /* A pure function may still have side-effects - it may modify its
6307 TREE_SIDE_EFFECTS (se->expr) = 1;
6309 if (!sym->attr.pure)
6310 TREE_SIDE_EFFECTS (se->expr) = 1;
6315 /* Add the function call to the pre chain. There is no expression. */
6316 gfc_add_expr_to_block (&se->pre, se->expr);
6317 se->expr = NULL_TREE;
6319 if (!se->direct_byref)
6321 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6323 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6325 /* Check the data pointer hasn't been modified. This would
6326 happen in a function returning a pointer. */
6327 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6328 tmp = fold_build2_loc (input_location, NE_EXPR,
6331 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6334 se->expr = info->descriptor;
6335 /* Bundle in the string length. */
6336 se->string_length = len;
6338 else if (ts.type == BT_CHARACTER)
6340 /* Dereference for character pointer results. */
6341 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6342 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6343 se->expr = build_fold_indirect_ref_loc (input_location, var);
6347 se->string_length = len;
6351 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6352 se->expr = build_fold_indirect_ref_loc (input_location, var);
6357 /* Associate the rhs class object's meta-data with the result, when the
6358 result is a temporary. */
6359 if (args && args->expr && args->expr->ts.type == BT_CLASS
6360 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6361 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6364 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6366 gfc_init_se (&parmse, NULL);
6367 parmse.data_not_needed = 1;
6368 gfc_conv_expr (&parmse, class_expr);
6369 if (!DECL_LANG_SPECIFIC (result))
6370 gfc_allocate_lang_decl (result);
6371 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6372 gfc_free_expr (class_expr);
6373 gcc_assert (parmse.pre.head == NULL_TREE
6374 && parmse.post.head == NULL_TREE);
6377 /* Follow the function call with the argument post block. */
6380 gfc_add_block_to_block (&se->pre, &post);
6382 /* Transformational functions of derived types with allocatable
6383 components must have the result allocatable components copied when the
6384 argument is actually given. */
6385 arg = expr->value.function.actual;
6386 if (result && arg && expr->rank
6387 && expr->value.function.isym
6388 && expr->value.function.isym->transformational
6390 && arg->expr->ts.type == BT_DERIVED
6391 && arg->expr->ts.u.derived->attr.alloc_comp)
6394 /* Copy the allocatable components. We have to use a
6395 temporary here to prevent source allocatable components
6396 from being corrupted. */
6397 tmp2 = gfc_evaluate_now (result, &se->pre);
6398 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6399 result, tmp2, expr->rank, 0);
6400 gfc_add_expr_to_block (&se->pre, tmp);
6401 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6403 gfc_add_expr_to_block (&se->pre, tmp);
6405 /* Finally free the temporary's data field. */
6406 tmp = gfc_conv_descriptor_data_get (tmp2);
6407 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6408 NULL_TREE, NULL_TREE, true,
6409 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6410 gfc_add_expr_to_block (&se->pre, tmp);
6415 /* For a function with a class array result, save the result as
6416 a temporary, set the info fields needed by the scalarizer and
6417 call the finalization function of the temporary. Note that the
6418 nullification of allocatable components needed by the result
6419 is done in gfc_trans_assignment_1. */
6420 if (expr && ((gfc_is_class_array_function (expr)
6421 && se->ss && se->ss->loop)
6422 || gfc_is_alloc_class_scalar_function (expr))
6423 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6424 && expr->must_finalize)
6429 if (se->ss && se->ss->loop)
6431 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6432 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6433 tmp = gfc_class_data_get (se->expr);
6434 info->descriptor = tmp;
6435 info->data = gfc_conv_descriptor_data_get (tmp);
6436 info->offset = gfc_conv_descriptor_offset_get (tmp);
6437 for (n = 0; n < se->ss->loop->dimen; n++)
6439 tree dim = gfc_rank_cst[n];
6440 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6441 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6446 /* TODO Eliminate the doubling of temporaries. This
6447 one is necessary to ensure no memory leakage. */
6448 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6449 tmp = gfc_class_data_get (se->expr);
6450 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6451 CLASS_DATA (expr->value.function.esym->result)->attr);
6454 if ((gfc_is_class_array_function (expr)
6455 || gfc_is_alloc_class_scalar_function (expr))
6456 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6457 goto no_finalization;
6459 final_fndecl = gfc_class_vtab_final_get (se->expr);
6460 is_final = fold_build2_loc (input_location, NE_EXPR,
6463 fold_convert (TREE_TYPE (final_fndecl),
6464 null_pointer_node));
6465 final_fndecl = build_fold_indirect_ref_loc (input_location,
6467 tmp = build_call_expr_loc (input_location,
6469 gfc_build_addr_expr (NULL, tmp),
6470 gfc_class_vtab_size_get (se->expr),
6471 boolean_false_node);
6472 tmp = fold_build3_loc (input_location, COND_EXPR,
6473 void_type_node, is_final, tmp,
6474 build_empty_stmt (input_location));
6476 if (se->ss && se->ss->loop)
6478 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6479 tmp = fold_build2_loc (input_location, NE_EXPR,
6482 fold_convert (TREE_TYPE (info->data),
6483 null_pointer_node));
6484 tmp = fold_build3_loc (input_location, COND_EXPR,
6485 void_type_node, tmp,
6486 gfc_call_free (info->data),
6487 build_empty_stmt (input_location));
6488 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6493 gfc_prepend_expr_to_block (&se->post, tmp);
6494 classdata = gfc_class_data_get (se->expr);
6495 tmp = fold_build2_loc (input_location, NE_EXPR,
6498 fold_convert (TREE_TYPE (classdata),
6499 null_pointer_node));
6500 tmp = fold_build3_loc (input_location, COND_EXPR,
6501 void_type_node, tmp,
6502 gfc_call_free (classdata),
6503 build_empty_stmt (input_location));
6504 gfc_add_expr_to_block (&se->post, tmp);
6509 gfc_add_block_to_block (&se->post, &post);
6512 return has_alternate_specifier;
6516 /* Fill a character string with spaces. */
6519 fill_with_spaces (tree start, tree type, tree size)
6521 stmtblock_t block, loop;
6522 tree i, el, exit_label, cond, tmp;
6524 /* For a simple char type, we can call memset(). */
6525 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6526 return build_call_expr_loc (input_location,
6527 builtin_decl_explicit (BUILT_IN_MEMSET),
6529 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6530 lang_hooks.to_target_charset (' ')),
6531 fold_convert (size_type_node, size));
6533 /* Otherwise, we use a loop:
6534 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6538 /* Initialize variables. */
6539 gfc_init_block (&block);
6540 i = gfc_create_var (sizetype, "i");
6541 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6542 el = gfc_create_var (build_pointer_type (type), "el");
6543 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6544 exit_label = gfc_build_label_decl (NULL_TREE);
6545 TREE_USED (exit_label) = 1;
6549 gfc_init_block (&loop);
6551 /* Exit condition. */
6552 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6553 build_zero_cst (sizetype));
6554 tmp = build1_v (GOTO_EXPR, exit_label);
6555 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6556 build_empty_stmt (input_location));
6557 gfc_add_expr_to_block (&loop, tmp);
6560 gfc_add_modify (&loop,
6561 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6562 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6564 /* Increment loop variables. */
6565 gfc_add_modify (&loop, i,
6566 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6567 TYPE_SIZE_UNIT (type)));
6568 gfc_add_modify (&loop, el,
6569 fold_build_pointer_plus_loc (input_location,
6570 el, TYPE_SIZE_UNIT (type)));
6572 /* Making the loop... actually loop! */
6573 tmp = gfc_finish_block (&loop);
6574 tmp = build1_v (LOOP_EXPR, tmp);
6575 gfc_add_expr_to_block (&block, tmp);
6577 /* The exit label. */
6578 tmp = build1_v (LABEL_EXPR, exit_label);
6579 gfc_add_expr_to_block (&block, tmp);
6582 return gfc_finish_block (&block);
6586 /* Generate code to copy a string. */
6589 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6590 int dkind, tree slength, tree src, int skind)
6592 tree tmp, dlen, slen;
6601 stmtblock_t tempblock;
6603 gcc_assert (dkind == skind);
6605 if (slength != NULL_TREE)
6607 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6608 ssc = gfc_string_to_single_character (slen, src, skind);
6612 slen = build_one_cst (gfc_charlen_type_node);
6616 if (dlength != NULL_TREE)
6618 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6619 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6623 dlen = build_one_cst (gfc_charlen_type_node);
6627 /* Assign directly if the types are compatible. */
6628 if (dsc != NULL_TREE && ssc != NULL_TREE
6629 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6631 gfc_add_modify (block, dsc, ssc);
6635 /* The string copy algorithm below generates code like
6639 if (srclen < destlen)
6641 memmove (dest, src, srclen);
6643 memset (&dest[srclen], ' ', destlen - srclen);
6647 // Truncate if too long.
6648 memmove (dest, src, destlen);
6653 /* Do nothing if the destination length is zero. */
6654 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6655 build_zero_cst (TREE_TYPE (dlen)));
6657 /* For non-default character kinds, we have to multiply the string
6658 length by the base type size. */
6659 chartype = gfc_get_char_type (dkind);
6660 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6662 fold_convert (TREE_TYPE (slen),
6663 TYPE_SIZE_UNIT (chartype)));
6664 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6666 fold_convert (TREE_TYPE (dlen),
6667 TYPE_SIZE_UNIT (chartype)));
6669 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6670 dest = fold_convert (pvoid_type_node, dest);
6672 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6674 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6675 src = fold_convert (pvoid_type_node, src);
6677 src = gfc_build_addr_expr (pvoid_type_node, src);
6679 /* Truncate string if source is too long. */
6680 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6683 /* Copy and pad with spaces. */
6684 tmp3 = build_call_expr_loc (input_location,
6685 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6687 fold_convert (size_type_node, slen));
6689 /* Wstringop-overflow appears at -O3 even though this warning is not
6690 explicitly available in fortran nor can it be switched off. If the
6691 source length is a constant, its negative appears as a very large
6692 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6693 the result of the MINUS_EXPR suppresses this spurious warning. */
6694 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6695 TREE_TYPE(dlen), dlen, slen);
6696 if (slength && TREE_CONSTANT (slength))
6697 tmp = gfc_evaluate_now (tmp, block);
6699 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6700 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6702 gfc_init_block (&tempblock);
6703 gfc_add_expr_to_block (&tempblock, tmp3);
6704 gfc_add_expr_to_block (&tempblock, tmp4);
6705 tmp3 = gfc_finish_block (&tempblock);
6707 /* The truncated memmove if the slen >= dlen. */
6708 tmp2 = build_call_expr_loc (input_location,
6709 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6711 fold_convert (size_type_node, dlen));
6713 /* The whole copy_string function is there. */
6714 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6716 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6717 build_empty_stmt (input_location));
6718 gfc_add_expr_to_block (block, tmp);
6722 /* Translate a statement function.
6723 The value of a statement function reference is obtained by evaluating the
6724 expression using the values of the actual arguments for the values of the
6725 corresponding dummy arguments. */
6728 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6732 gfc_formal_arglist *fargs;
6733 gfc_actual_arglist *args;
6736 gfc_saved_var *saved_vars;
6742 sym = expr->symtree->n.sym;
6743 args = expr->value.function.actual;
6744 gfc_init_se (&lse, NULL);
6745 gfc_init_se (&rse, NULL);
6748 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6750 saved_vars = XCNEWVEC (gfc_saved_var, n);
6751 temp_vars = XCNEWVEC (tree, n);
6753 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6754 fargs = fargs->next, n++)
6756 /* Each dummy shall be specified, explicitly or implicitly, to be
6758 gcc_assert (fargs->sym->attr.dimension == 0);
6761 if (fsym->ts.type == BT_CHARACTER)
6763 /* Copy string arguments. */
6766 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6767 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6769 /* Create a temporary to hold the value. */
6770 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6771 fsym->ts.u.cl->backend_decl
6772 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6774 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6775 temp_vars[n] = gfc_create_var (type, fsym->name);
6777 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6779 gfc_conv_expr (&rse, args->expr);
6780 gfc_conv_string_parameter (&rse);
6781 gfc_add_block_to_block (&se->pre, &lse.pre);
6782 gfc_add_block_to_block (&se->pre, &rse.pre);
6784 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6785 rse.string_length, rse.expr, fsym->ts.kind);
6786 gfc_add_block_to_block (&se->pre, &lse.post);
6787 gfc_add_block_to_block (&se->pre, &rse.post);
6791 /* For everything else, just evaluate the expression. */
6793 /* Create a temporary to hold the value. */
6794 type = gfc_typenode_for_spec (&fsym->ts);
6795 temp_vars[n] = gfc_create_var (type, fsym->name);
6797 gfc_conv_expr (&lse, args->expr);
6799 gfc_add_block_to_block (&se->pre, &lse.pre);
6800 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6801 gfc_add_block_to_block (&se->pre, &lse.post);
6807 /* Use the temporary variables in place of the real ones. */
6808 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6809 fargs = fargs->next, n++)
6810 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6812 gfc_conv_expr (se, sym->value);
6814 if (sym->ts.type == BT_CHARACTER)
6816 gfc_conv_const_charlen (sym->ts.u.cl);
6818 /* Force the expression to the correct length. */
6819 if (!INTEGER_CST_P (se->string_length)
6820 || tree_int_cst_lt (se->string_length,
6821 sym->ts.u.cl->backend_decl))
6823 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6824 tmp = gfc_create_var (type, sym->name);
6825 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6826 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6827 sym->ts.kind, se->string_length, se->expr,
6831 se->string_length = sym->ts.u.cl->backend_decl;
6834 /* Restore the original variables. */
6835 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6836 fargs = fargs->next, n++)
6837 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6843 /* Translate a function expression. */
6846 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6850 if (expr->value.function.isym)
6852 gfc_conv_intrinsic_function (se, expr);
6856 /* expr.value.function.esym is the resolved (specific) function symbol for
6857 most functions. However this isn't set for dummy procedures. */
6858 sym = expr->value.function.esym;
6860 sym = expr->symtree->n.sym;
6862 /* The IEEE_ARITHMETIC functions are caught here. */
6863 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6864 if (gfc_conv_ieee_arithmetic_function (se, expr))
6867 /* We distinguish statement functions from general functions to improve
6868 runtime performance. */
6869 if (sym->attr.proc == PROC_ST_FUNCTION)
6871 gfc_conv_statement_function (se, expr);
6875 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6880 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6883 is_zero_initializer_p (gfc_expr * expr)
6885 if (expr->expr_type != EXPR_CONSTANT)
6888 /* We ignore constants with prescribed memory representations for now. */
6889 if (expr->representation.string)
6892 switch (expr->ts.type)
6895 return mpz_cmp_si (expr->value.integer, 0) == 0;
6898 return mpfr_zero_p (expr->value.real)
6899 && MPFR_SIGN (expr->value.real) >= 0;
6902 return expr->value.logical == 0;
6905 return mpfr_zero_p (mpc_realref (expr->value.complex))
6906 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6907 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6908 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6918 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6923 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6924 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6926 gfc_conv_tmp_array_ref (se);
6930 /* Build a static initializer. EXPR is the expression for the initial value.
6931 The other parameters describe the variable of the component being
6932 initialized. EXPR may be null. */
6935 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6936 bool array, bool pointer, bool procptr)
6940 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6941 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6942 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6943 return build_constructor (type, NULL);
6945 if (!(expr || pointer || procptr))
6948 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6949 (these are the only two iso_c_binding derived types that can be
6950 used as initialization expressions). If so, we need to modify
6951 the 'expr' to be that for a (void *). */
6952 if (expr != NULL && expr->ts.type == BT_DERIVED
6953 && expr->ts.is_iso_c && expr->ts.u.derived)
6955 gfc_symbol *derived = expr->ts.u.derived;
6957 /* The derived symbol has already been converted to a (void *). Use
6959 if (derived->ts.kind == 0)
6960 derived->ts.kind = gfc_default_integer_kind;
6961 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
6962 expr->ts.f90_type = derived->ts.f90_type;
6964 gfc_init_se (&se, NULL);
6965 gfc_conv_constant (&se, expr);
6966 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6970 if (array && !procptr)
6973 /* Arrays need special handling. */
6975 ctor = gfc_build_null_descriptor (type);
6976 /* Special case assigning an array to zero. */
6977 else if (is_zero_initializer_p (expr))
6978 ctor = build_constructor (type, NULL);
6980 ctor = gfc_conv_array_initializer (type, expr);
6981 TREE_STATIC (ctor) = 1;
6984 else if (pointer || procptr)
6986 if (ts->type == BT_CLASS && !procptr)
6988 gfc_init_se (&se, NULL);
6989 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
6990 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
6991 TREE_STATIC (se.expr) = 1;
6994 else if (!expr || expr->expr_type == EXPR_NULL)
6995 return fold_convert (type, null_pointer_node);
6998 gfc_init_se (&se, NULL);
6999 se.want_pointer = 1;
7000 gfc_conv_expr (&se, expr);
7001 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7011 gfc_init_se (&se, NULL);
7012 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7013 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7015 gfc_conv_structure (&se, expr, 1);
7016 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7017 TREE_STATIC (se.expr) = 1;
7022 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7023 TREE_STATIC (ctor) = 1;
7028 gfc_init_se (&se, NULL);
7029 gfc_conv_constant (&se, expr);
7030 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7037 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7043 gfc_array_info *lss_array;
7050 gfc_start_block (&block);
7052 /* Initialize the scalarizer. */
7053 gfc_init_loopinfo (&loop);
7055 gfc_init_se (&lse, NULL);
7056 gfc_init_se (&rse, NULL);
7059 rss = gfc_walk_expr (expr);
7060 if (rss == gfc_ss_terminator)
7061 /* The rhs is scalar. Add a ss for the expression. */
7062 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7064 /* Create a SS for the destination. */
7065 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7067 lss_array = &lss->info->data.array;
7068 lss_array->shape = gfc_get_shape (cm->as->rank);
7069 lss_array->descriptor = dest;
7070 lss_array->data = gfc_conv_array_data (dest);
7071 lss_array->offset = gfc_conv_array_offset (dest);
7072 for (n = 0; n < cm->as->rank; n++)
7074 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7075 lss_array->stride[n] = gfc_index_one_node;
7077 mpz_init (lss_array->shape[n]);
7078 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7079 cm->as->lower[n]->value.integer);
7080 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7083 /* Associate the SS with the loop. */
7084 gfc_add_ss_to_loop (&loop, lss);
7085 gfc_add_ss_to_loop (&loop, rss);
7087 /* Calculate the bounds of the scalarization. */
7088 gfc_conv_ss_startstride (&loop);
7090 /* Setup the scalarizing loops. */
7091 gfc_conv_loop_setup (&loop, &expr->where);
7093 /* Setup the gfc_se structures. */
7094 gfc_copy_loopinfo_to_se (&lse, &loop);
7095 gfc_copy_loopinfo_to_se (&rse, &loop);
7098 gfc_mark_ss_chain_used (rss, 1);
7100 gfc_mark_ss_chain_used (lss, 1);
7102 /* Start the scalarized loop body. */
7103 gfc_start_scalarized_body (&loop, &body);
7105 gfc_conv_tmp_array_ref (&lse);
7106 if (cm->ts.type == BT_CHARACTER)
7107 lse.string_length = cm->ts.u.cl->backend_decl;
7109 gfc_conv_expr (&rse, expr);
7111 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7112 gfc_add_expr_to_block (&body, tmp);
7114 gcc_assert (rse.ss == gfc_ss_terminator);
7116 /* Generate the copying loops. */
7117 gfc_trans_scalarizing_loops (&loop, &body);
7119 /* Wrap the whole thing up. */
7120 gfc_add_block_to_block (&block, &loop.pre);
7121 gfc_add_block_to_block (&block, &loop.post);
7123 gcc_assert (lss_array->shape != NULL);
7124 gfc_free_shape (&lss_array->shape, cm->as->rank);
7125 gfc_cleanup_loop (&loop);
7127 return gfc_finish_block (&block);
7132 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7142 gfc_expr *arg = NULL;
7144 gfc_start_block (&block);
7145 gfc_init_se (&se, NULL);
7147 /* Get the descriptor for the expressions. */
7148 se.want_pointer = 0;
7149 gfc_conv_expr_descriptor (&se, expr);
7150 gfc_add_block_to_block (&block, &se.pre);
7151 gfc_add_modify (&block, dest, se.expr);
7153 /* Deal with arrays of derived types with allocatable components. */
7154 if (gfc_bt_struct (cm->ts.type)
7155 && cm->ts.u.derived->attr.alloc_comp)
7156 // TODO: Fix caf_mode
7157 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7160 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7161 && CLASS_DATA(cm)->attr.allocatable)
7163 if (cm->ts.u.derived->attr.alloc_comp)
7164 // TODO: Fix caf_mode
7165 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7170 tmp = TREE_TYPE (dest);
7171 tmp = gfc_duplicate_allocatable (dest, se.expr,
7172 tmp, expr->rank, NULL_TREE);
7176 tmp = gfc_duplicate_allocatable (dest, se.expr,
7177 TREE_TYPE(cm->backend_decl),
7178 cm->as->rank, NULL_TREE);
7180 gfc_add_expr_to_block (&block, tmp);
7181 gfc_add_block_to_block (&block, &se.post);
7183 if (expr->expr_type != EXPR_VARIABLE)
7184 gfc_conv_descriptor_data_set (&block, se.expr,
7187 /* We need to know if the argument of a conversion function is a
7188 variable, so that the correct lower bound can be used. */
7189 if (expr->expr_type == EXPR_FUNCTION
7190 && expr->value.function.isym
7191 && expr->value.function.isym->conversion
7192 && expr->value.function.actual->expr
7193 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7194 arg = expr->value.function.actual->expr;
7196 /* Obtain the array spec of full array references. */
7198 as = gfc_get_full_arrayspec_from_expr (arg);
7200 as = gfc_get_full_arrayspec_from_expr (expr);
7202 /* Shift the lbound and ubound of temporaries to being unity,
7203 rather than zero, based. Always calculate the offset. */
7204 offset = gfc_conv_descriptor_offset_get (dest);
7205 gfc_add_modify (&block, offset, gfc_index_zero_node);
7206 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7208 for (n = 0; n < expr->rank; n++)
7213 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7214 TODO It looks as if gfc_conv_expr_descriptor should return
7215 the correct bounds and that the following should not be
7216 necessary. This would simplify gfc_conv_intrinsic_bound
7218 if (as && as->lower[n])
7221 gfc_init_se (&lbse, NULL);
7222 gfc_conv_expr (&lbse, as->lower[n]);
7223 gfc_add_block_to_block (&block, &lbse.pre);
7224 lbound = gfc_evaluate_now (lbse.expr, &block);
7228 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7229 lbound = gfc_conv_descriptor_lbound_get (tmp,
7233 lbound = gfc_conv_descriptor_lbound_get (dest,
7236 lbound = gfc_index_one_node;
7238 lbound = fold_convert (gfc_array_index_type, lbound);
7240 /* Shift the bounds and set the offset accordingly. */
7241 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7242 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7243 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7244 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7246 gfc_conv_descriptor_ubound_set (&block, dest,
7247 gfc_rank_cst[n], tmp);
7248 gfc_conv_descriptor_lbound_set (&block, dest,
7249 gfc_rank_cst[n], lbound);
7251 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7252 gfc_conv_descriptor_lbound_get (dest,
7254 gfc_conv_descriptor_stride_get (dest,
7256 gfc_add_modify (&block, tmp2, tmp);
7257 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7259 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7264 /* If a conversion expression has a null data pointer
7265 argument, nullify the allocatable component. */
7269 if (arg->symtree->n.sym->attr.allocatable
7270 || arg->symtree->n.sym->attr.pointer)
7272 non_null_expr = gfc_finish_block (&block);
7273 gfc_start_block (&block);
7274 gfc_conv_descriptor_data_set (&block, dest,
7276 null_expr = gfc_finish_block (&block);
7277 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7278 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7279 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7280 return build3_v (COND_EXPR, tmp,
7281 null_expr, non_null_expr);
7285 return gfc_finish_block (&block);
7289 /* Allocate or reallocate scalar component, as necessary. */
7292 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7302 tree lhs_cl_size = NULL_TREE;
7307 if (!expr2 || expr2->rank)
7310 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7312 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7314 char name[GFC_MAX_SYMBOL_LEN+9];
7315 gfc_component *strlen;
7316 /* Use the rhs string length and the lhs element size. */
7317 gcc_assert (expr2->ts.type == BT_CHARACTER);
7318 if (!expr2->ts.u.cl->backend_decl)
7320 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7321 gcc_assert (expr2->ts.u.cl->backend_decl);
7324 size = expr2->ts.u.cl->backend_decl;
7326 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7328 sprintf (name, "_%s_length", cm->name);
7329 strlen = gfc_find_component (sym, name, true, true, NULL);
7330 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7331 gfc_charlen_type_node,
7332 TREE_OPERAND (comp, 0),
7333 strlen->backend_decl, NULL_TREE);
7335 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7336 tmp = TYPE_SIZE_UNIT (tmp);
7337 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7338 TREE_TYPE (tmp), tmp,
7339 fold_convert (TREE_TYPE (tmp), size));
7341 else if (cm->ts.type == BT_CLASS)
7343 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7344 if (expr2->ts.type == BT_DERIVED)
7346 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7347 size = TYPE_SIZE_UNIT (tmp);
7353 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7354 gfc_add_vptr_component (e2vtab);
7355 gfc_add_size_component (e2vtab);
7356 gfc_init_se (&se, NULL);
7357 gfc_conv_expr (&se, e2vtab);
7358 gfc_add_block_to_block (block, &se.pre);
7359 size = fold_convert (size_type_node, se.expr);
7360 gfc_free_expr (e2vtab);
7362 size_in_bytes = size;
7366 /* Otherwise use the length in bytes of the rhs. */
7367 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7368 size_in_bytes = size;
7371 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7372 size_in_bytes, size_one_node);
7374 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7376 tmp = build_call_expr_loc (input_location,
7377 builtin_decl_explicit (BUILT_IN_CALLOC),
7378 2, build_one_cst (size_type_node),
7380 tmp = fold_convert (TREE_TYPE (comp), tmp);
7381 gfc_add_modify (block, comp, tmp);
7385 tmp = build_call_expr_loc (input_location,
7386 builtin_decl_explicit (BUILT_IN_MALLOC),
7388 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7389 ptr = gfc_class_data_get (comp);
7392 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7393 gfc_add_modify (block, ptr, tmp);
7396 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7397 /* Update the lhs character length. */
7398 gfc_add_modify (block, lhs_cl_size,
7399 fold_convert (TREE_TYPE (lhs_cl_size), size));
7403 /* Assign a single component of a derived type constructor. */
7406 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7407 gfc_symbol *sym, bool init)
7415 gfc_start_block (&block);
7417 if (cm->attr.pointer || cm->attr.proc_pointer)
7419 /* Only care about pointers here, not about allocatables. */
7420 gfc_init_se (&se, NULL);
7421 /* Pointer component. */
7422 if ((cm->attr.dimension || cm->attr.codimension)
7423 && !cm->attr.proc_pointer)
7425 /* Array pointer. */
7426 if (expr->expr_type == EXPR_NULL)
7427 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7430 se.direct_byref = 1;
7432 gfc_conv_expr_descriptor (&se, expr);
7433 gfc_add_block_to_block (&block, &se.pre);
7434 gfc_add_block_to_block (&block, &se.post);
7439 /* Scalar pointers. */
7440 se.want_pointer = 1;
7441 gfc_conv_expr (&se, expr);
7442 gfc_add_block_to_block (&block, &se.pre);
7444 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7445 && expr->symtree->n.sym->attr.dummy)
7446 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7448 gfc_add_modify (&block, dest,
7449 fold_convert (TREE_TYPE (dest), se.expr));
7450 gfc_add_block_to_block (&block, &se.post);
7453 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7455 /* NULL initialization for CLASS components. */
7456 tmp = gfc_trans_structure_assign (dest,
7457 gfc_class_initializer (&cm->ts, expr),
7459 gfc_add_expr_to_block (&block, tmp);
7461 else if ((cm->attr.dimension || cm->attr.codimension)
7462 && !cm->attr.proc_pointer)
7464 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7465 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7466 else if (cm->attr.allocatable || cm->attr.pdt_array)
7468 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7469 gfc_add_expr_to_block (&block, tmp);
7473 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7474 gfc_add_expr_to_block (&block, tmp);
7477 else if (cm->ts.type == BT_CLASS
7478 && CLASS_DATA (cm)->attr.dimension
7479 && CLASS_DATA (cm)->attr.allocatable
7480 && expr->ts.type == BT_DERIVED)
7482 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7483 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7484 tmp = gfc_class_vptr_get (dest);
7485 gfc_add_modify (&block, tmp,
7486 fold_convert (TREE_TYPE (tmp), vtab));
7487 tmp = gfc_class_data_get (dest);
7488 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7489 gfc_add_expr_to_block (&block, tmp);
7491 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7493 /* NULL initialization for allocatable components. */
7494 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7495 null_pointer_node));
7497 else if (init && (cm->attr.allocatable
7498 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7499 && expr->ts.type != BT_CLASS)))
7501 /* Take care about non-array allocatable components here. The alloc_*
7502 routine below is motivated by the alloc_scalar_allocatable_for_
7503 assignment() routine, but with the realloc portions removed and
7505 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7510 /* The remainder of these instructions follow the if (cm->attr.pointer)
7511 if (!cm->attr.dimension) part above. */
7512 gfc_init_se (&se, NULL);
7513 gfc_conv_expr (&se, expr);
7514 gfc_add_block_to_block (&block, &se.pre);
7516 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7517 && expr->symtree->n.sym->attr.dummy)
7518 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7520 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7522 tmp = gfc_class_data_get (dest);
7523 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7524 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7525 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7526 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7527 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7530 tmp = build_fold_indirect_ref_loc (input_location, dest);
7532 /* For deferred strings insert a memcpy. */
7533 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7536 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7537 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7539 : expr->ts.u.cl->backend_decl);
7540 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7541 gfc_add_expr_to_block (&block, tmp);
7544 gfc_add_modify (&block, tmp,
7545 fold_convert (TREE_TYPE (tmp), se.expr));
7546 gfc_add_block_to_block (&block, &se.post);
7548 else if (expr->ts.type == BT_UNION)
7551 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7552 /* We mark that the entire union should be initialized with a contrived
7553 EXPR_NULL expression at the beginning. */
7554 if (c != NULL && c->n.component == NULL
7555 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7557 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7558 dest, build_constructor (TREE_TYPE (dest), NULL));
7559 gfc_add_expr_to_block (&block, tmp);
7560 c = gfc_constructor_next (c);
7562 /* The following constructor expression, if any, represents a specific
7563 map intializer, as given by the user. */
7564 if (c != NULL && c->expr != NULL)
7566 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7567 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7568 gfc_add_expr_to_block (&block, tmp);
7571 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7573 if (expr->expr_type != EXPR_STRUCTURE)
7575 tree dealloc = NULL_TREE;
7576 gfc_init_se (&se, NULL);
7577 gfc_conv_expr (&se, expr);
7578 gfc_add_block_to_block (&block, &se.pre);
7579 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7580 expression in a temporary variable and deallocate the allocatable
7581 components. Then we can the copy the expression to the result. */
7582 if (cm->ts.u.derived->attr.alloc_comp
7583 && expr->expr_type != EXPR_VARIABLE)
7585 se.expr = gfc_evaluate_now (se.expr, &block);
7586 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7589 gfc_add_modify (&block, dest,
7590 fold_convert (TREE_TYPE (dest), se.expr));
7591 if (cm->ts.u.derived->attr.alloc_comp
7592 && expr->expr_type != EXPR_NULL)
7594 // TODO: Fix caf_mode
7595 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7596 dest, expr->rank, 0);
7597 gfc_add_expr_to_block (&block, tmp);
7598 if (dealloc != NULL_TREE)
7599 gfc_add_expr_to_block (&block, dealloc);
7601 gfc_add_block_to_block (&block, &se.post);
7605 /* Nested constructors. */
7606 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7607 gfc_add_expr_to_block (&block, tmp);
7610 else if (gfc_deferred_strlen (cm, &tmp))
7614 gcc_assert (strlen);
7615 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7617 TREE_OPERAND (dest, 0),
7620 if (expr->expr_type == EXPR_NULL)
7622 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7623 gfc_add_modify (&block, dest, tmp);
7624 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7625 gfc_add_modify (&block, strlen, tmp);
7630 gfc_init_se (&se, NULL);
7631 gfc_conv_expr (&se, expr);
7632 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7633 tmp = build_call_expr_loc (input_location,
7634 builtin_decl_explicit (BUILT_IN_MALLOC),
7636 gfc_add_modify (&block, dest,
7637 fold_convert (TREE_TYPE (dest), tmp));
7638 gfc_add_modify (&block, strlen,
7639 fold_convert (TREE_TYPE (strlen), se.string_length));
7640 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7641 gfc_add_expr_to_block (&block, tmp);
7644 else if (!cm->attr.artificial)
7646 /* Scalar component (excluding deferred parameters). */
7647 gfc_init_se (&se, NULL);
7648 gfc_init_se (&lse, NULL);
7650 gfc_conv_expr (&se, expr);
7651 if (cm->ts.type == BT_CHARACTER)
7652 lse.string_length = cm->ts.u.cl->backend_decl;
7654 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7655 gfc_add_expr_to_block (&block, tmp);
7657 return gfc_finish_block (&block);
7660 /* Assign a derived type constructor to a variable. */
7663 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7672 gfc_start_block (&block);
7673 cm = expr->ts.u.derived->components;
7675 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7676 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7677 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7681 gfc_init_se (&se, NULL);
7682 gfc_init_se (&lse, NULL);
7683 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7685 gfc_add_modify (&block, lse.expr,
7686 fold_convert (TREE_TYPE (lse.expr), se.expr));
7688 return gfc_finish_block (&block);
7692 gfc_init_se (&se, NULL);
7694 for (c = gfc_constructor_first (expr->value.constructor);
7695 c; c = gfc_constructor_next (c), cm = cm->next)
7697 /* Skip absent members in default initializers. */
7698 if (!c->expr && !cm->attr.allocatable)
7701 /* Register the component with the caf-lib before it is initialized.
7702 Register only allocatable components, that are not coarray'ed
7703 components (%comp[*]). Only register when the constructor is not the
7705 if (coarray && !cm->attr.codimension
7706 && (cm->attr.allocatable || cm->attr.pointer)
7707 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7709 tree token, desc, size;
7710 bool is_array = cm->ts.type == BT_CLASS
7711 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7713 field = cm->backend_decl;
7714 field = fold_build3_loc (input_location, COMPONENT_REF,
7715 TREE_TYPE (field), dest, field, NULL_TREE);
7716 if (cm->ts.type == BT_CLASS)
7717 field = gfc_class_data_get (field);
7719 token = is_array ? gfc_conv_descriptor_token (field)
7720 : fold_build3_loc (input_location, COMPONENT_REF,
7721 TREE_TYPE (cm->caf_token), dest,
7722 cm->caf_token, NULL_TREE);
7726 /* The _caf_register routine looks at the rank of the array
7727 descriptor to decide whether the data registered is an array
7729 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7731 /* When the rank is not known just set a positive rank, which
7732 suffices to recognize the data as array. */
7735 size = integer_zero_node;
7737 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7738 build_int_cst (signed_char_type_node, rank));
7742 desc = gfc_conv_scalar_to_descriptor (&se, field,
7743 cm->ts.type == BT_CLASS
7744 ? CLASS_DATA (cm)->attr
7746 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7748 gfc_add_block_to_block (&block, &se.pre);
7749 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7750 7, size, build_int_cst (
7752 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7753 gfc_build_addr_expr (pvoid_type_node,
7755 gfc_build_addr_expr (NULL_TREE, desc),
7756 null_pointer_node, null_pointer_node,
7758 gfc_add_expr_to_block (&block, tmp);
7760 field = cm->backend_decl;
7761 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7762 dest, field, NULL_TREE);
7765 gfc_expr *e = gfc_get_null_expr (NULL);
7766 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7771 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7772 expr->ts.u.derived, init);
7773 gfc_add_expr_to_block (&block, tmp);
7775 return gfc_finish_block (&block);
7779 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7780 gfc_component *un, gfc_expr *init)
7782 gfc_constructor *ctor;
7784 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7787 ctor = gfc_constructor_first (init->value.constructor);
7789 if (ctor == NULL || ctor->expr == NULL)
7792 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7794 /* If we have an 'initialize all' constructor, do it first. */
7795 if (ctor->expr->expr_type == EXPR_NULL)
7797 tree union_type = TREE_TYPE (un->backend_decl);
7798 tree val = build_constructor (union_type, NULL);
7799 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7800 ctor = gfc_constructor_next (ctor);
7803 /* Add the map initializer on top. */
7804 if (ctor != NULL && ctor->expr != NULL)
7806 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7807 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7808 TREE_TYPE (un->backend_decl),
7809 un->attr.dimension, un->attr.pointer,
7810 un->attr.proc_pointer);
7811 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7815 /* Build an expression for a constructor. If init is nonzero then
7816 this is part of a static variable initializer. */
7819 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7826 vec<constructor_elt, va_gc> *v = NULL;
7828 gcc_assert (se->ss == NULL);
7829 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7830 type = gfc_typenode_for_spec (&expr->ts);
7834 /* Create a temporary variable and fill it in. */
7835 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7836 /* The symtree in expr is NULL, if the code to generate is for
7837 initializing the static members only. */
7838 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7840 gfc_add_expr_to_block (&se->pre, tmp);
7844 cm = expr->ts.u.derived->components;
7846 for (c = gfc_constructor_first (expr->value.constructor);
7847 c; c = gfc_constructor_next (c), cm = cm->next)
7849 /* Skip absent members in default initializers and allocatable
7850 components. Although the latter have a default initializer
7851 of EXPR_NULL,... by default, the static nullify is not needed
7852 since this is done every time we come into scope. */
7853 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7856 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7857 && strcmp (cm->name, "_extends") == 0
7858 && cm->initializer->symtree)
7862 vtabs = cm->initializer->symtree->n.sym;
7863 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7864 vtab = unshare_expr_without_location (vtab);
7865 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7867 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7869 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7870 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7871 fold_convert (TREE_TYPE (cm->backend_decl),
7874 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7875 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7876 fold_convert (TREE_TYPE (cm->backend_decl),
7877 integer_zero_node));
7878 else if (cm->ts.type == BT_UNION)
7879 gfc_conv_union_initializer (v, cm, c->expr);
7882 val = gfc_conv_initializer (c->expr, &cm->ts,
7883 TREE_TYPE (cm->backend_decl),
7884 cm->attr.dimension, cm->attr.pointer,
7885 cm->attr.proc_pointer);
7886 val = unshare_expr_without_location (val);
7888 /* Append it to the constructor list. */
7889 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7893 se->expr = build_constructor (type, v);
7895 TREE_CONSTANT (se->expr) = 1;
7899 /* Translate a substring expression. */
7902 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7908 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7910 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7911 expr->value.character.length,
7912 expr->value.character.string);
7914 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7915 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7918 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7922 /* Entry point for expression translation. Evaluates a scalar quantity.
7923 EXPR is the expression to be translated, and SE is the state structure if
7924 called from within the scalarized. */
7927 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7932 if (ss && ss->info->expr == expr
7933 && (ss->info->type == GFC_SS_SCALAR
7934 || ss->info->type == GFC_SS_REFERENCE))
7936 gfc_ss_info *ss_info;
7939 /* Substitute a scalar expression evaluated outside the scalarization
7941 se->expr = ss_info->data.scalar.value;
7942 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7943 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7945 se->string_length = ss_info->string_length;
7946 gfc_advance_se_ss_chain (se);
7950 /* We need to convert the expressions for the iso_c_binding derived types.
7951 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7952 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7953 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7954 updated to be an integer with a kind equal to the size of a (void *). */
7955 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
7956 && expr->ts.u.derived->attr.is_bind_c)
7958 if (expr->expr_type == EXPR_VARIABLE
7959 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
7960 || expr->symtree->n.sym->intmod_sym_id
7961 == ISOCBINDING_NULL_FUNPTR))
7963 /* Set expr_type to EXPR_NULL, which will result in
7964 null_pointer_node being used below. */
7965 expr->expr_type = EXPR_NULL;
7969 /* Update the type/kind of the expression to be what the new
7970 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7971 expr->ts.type = BT_INTEGER;
7972 expr->ts.f90_type = BT_VOID;
7973 expr->ts.kind = gfc_index_integer_kind;
7977 gfc_fix_class_refs (expr);
7979 switch (expr->expr_type)
7982 gfc_conv_expr_op (se, expr);
7986 gfc_conv_function_expr (se, expr);
7990 gfc_conv_constant (se, expr);
7994 gfc_conv_variable (se, expr);
7998 se->expr = null_pointer_node;
8001 case EXPR_SUBSTRING:
8002 gfc_conv_substring_expr (se, expr);
8005 case EXPR_STRUCTURE:
8006 gfc_conv_structure (se, expr, 0);
8010 gfc_conv_array_constructor_expr (se, expr);
8019 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8020 of an assignment. */
8022 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8024 gfc_conv_expr (se, expr);
8025 /* All numeric lvalues should have empty post chains. If not we need to
8026 figure out a way of rewriting an lvalue so that it has no post chain. */
8027 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8030 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8031 numeric expressions. Used for scalar values where inserting cleanup code
8034 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8038 gcc_assert (expr->ts.type != BT_CHARACTER);
8039 gfc_conv_expr (se, expr);
8042 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8043 gfc_add_modify (&se->pre, val, se->expr);
8045 gfc_add_block_to_block (&se->pre, &se->post);
8049 /* Helper to translate an expression and convert it to a particular type. */
8051 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8053 gfc_conv_expr_val (se, expr);
8054 se->expr = convert (type, se->expr);
8058 /* Converts an expression so that it can be passed by reference. Scalar
8062 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
8068 if (ss && ss->info->expr == expr
8069 && ss->info->type == GFC_SS_REFERENCE)
8071 /* Returns a reference to the scalar evaluated outside the loop
8073 gfc_conv_expr (se, expr);
8075 if (expr->ts.type == BT_CHARACTER
8076 && expr->expr_type != EXPR_FUNCTION)
8077 gfc_conv_string_parameter (se);
8079 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8084 if (expr->ts.type == BT_CHARACTER)
8086 gfc_conv_expr (se, expr);
8087 gfc_conv_string_parameter (se);
8091 if (expr->expr_type == EXPR_VARIABLE)
8093 se->want_pointer = 1;
8094 gfc_conv_expr (se, expr);
8097 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8098 gfc_add_modify (&se->pre, var, se->expr);
8099 gfc_add_block_to_block (&se->pre, &se->post);
8105 if (expr->expr_type == EXPR_FUNCTION
8106 && ((expr->value.function.esym
8107 && expr->value.function.esym->result->attr.pointer
8108 && !expr->value.function.esym->result->attr.dimension)
8109 || (!expr->value.function.esym && !expr->ref
8110 && expr->symtree->n.sym->attr.pointer
8111 && !expr->symtree->n.sym->attr.dimension)))
8113 se->want_pointer = 1;
8114 gfc_conv_expr (se, expr);
8115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8116 gfc_add_modify (&se->pre, var, se->expr);
8121 gfc_conv_expr (se, expr);
8123 /* Create a temporary var to hold the value. */
8124 if (TREE_CONSTANT (se->expr))
8126 tree tmp = se->expr;
8127 STRIP_TYPE_NOPS (tmp);
8128 var = build_decl (input_location,
8129 CONST_DECL, NULL, TREE_TYPE (tmp));
8130 DECL_INITIAL (var) = tmp;
8131 TREE_STATIC (var) = 1;
8136 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8137 gfc_add_modify (&se->pre, var, se->expr);
8140 if (!expr->must_finalize)
8141 gfc_add_block_to_block (&se->pre, &se->post);
8143 /* Take the address of that value. */
8144 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8148 /* Get the _len component for an unlimited polymorphic expression. */
8151 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8154 gfc_ref *ref = expr->ref;
8156 gfc_init_se (&se, NULL);
8157 while (ref && ref->next)
8159 gfc_add_len_component (expr);
8160 gfc_conv_expr (&se, expr);
8161 gfc_add_block_to_block (block, &se.pre);
8162 gcc_assert (se.post.head == NULL_TREE);
8165 gfc_free_ref_list (ref->next);
8170 gfc_free_ref_list (expr->ref);
8177 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8178 statement-list outside of the scalarizer-loop. When code is generated, that
8179 depends on the scalarized expression, it is added to RSE.PRE.
8180 Returns le's _vptr tree and when set the len expressions in to_lenp and
8181 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8185 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8186 gfc_expr * re, gfc_se *rse,
8187 tree * to_lenp, tree * from_lenp)
8190 gfc_expr * vptr_expr;
8191 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8192 bool set_vptr = false, temp_rhs = false;
8193 stmtblock_t *pre = block;
8195 /* Create a temporary for complicated expressions. */
8196 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8197 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8199 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8201 gfc_add_modify (&rse->pre, tmp, rse->expr);
8206 /* Get the _vptr for the left-hand side expression. */
8207 gfc_init_se (&se, NULL);
8208 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8209 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8211 /* Care about _len for unlimited polymorphic entities. */
8212 if (UNLIMITED_POLY (vptr_expr)
8213 || (vptr_expr->ts.type == BT_DERIVED
8214 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8215 to_len = trans_get_upoly_len (block, vptr_expr);
8216 gfc_add_vptr_component (vptr_expr);
8220 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8221 se.want_pointer = 1;
8222 gfc_conv_expr (&se, vptr_expr);
8223 gfc_free_expr (vptr_expr);
8224 gfc_add_block_to_block (block, &se.pre);
8225 gcc_assert (se.post.head == NULL_TREE);
8227 STRIP_NOPS (lhs_vptr);
8229 /* Set the _vptr only when the left-hand side of the assignment is a
8233 /* Get the vptr from the rhs expression only, when it is variable.
8234 Functions are expected to be assigned to a temporary beforehand. */
8235 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8236 ? gfc_find_and_cut_at_last_class_ref (re)
8238 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8240 if (to_len != NULL_TREE)
8242 /* Get the _len information from the rhs. */
8243 if (UNLIMITED_POLY (vptr_expr)
8244 || (vptr_expr->ts.type == BT_DERIVED
8245 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8246 from_len = trans_get_upoly_len (block, vptr_expr);
8248 gfc_add_vptr_component (vptr_expr);
8252 if (re->expr_type == EXPR_VARIABLE
8253 && DECL_P (re->symtree->n.sym->backend_decl)
8254 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8255 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8256 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8257 re->symtree->n.sym->backend_decl))))
8260 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8261 re->symtree->n.sym->backend_decl));
8263 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8264 re->symtree->n.sym->backend_decl));
8266 else if (temp_rhs && re->ts.type == BT_CLASS)
8269 se.expr = gfc_class_vptr_get (rse->expr);
8270 if (UNLIMITED_POLY (re))
8271 from_len = gfc_class_len_get (rse->expr);
8273 else if (re->expr_type != EXPR_NULL)
8274 /* Only when rhs is non-NULL use its declared type for vptr
8276 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8278 /* When the rhs is NULL use the vtab of lhs' declared type. */
8279 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8284 gfc_init_se (&se, NULL);
8285 se.want_pointer = 1;
8286 gfc_conv_expr (&se, vptr_expr);
8287 gfc_free_expr (vptr_expr);
8288 gfc_add_block_to_block (block, &se.pre);
8289 gcc_assert (se.post.head == NULL_TREE);
8291 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8294 if (to_len != NULL_TREE)
8296 /* The _len component needs to be set. Figure how to get the
8297 value of the right-hand side. */
8298 if (from_len == NULL_TREE)
8300 if (rse->string_length != NULL_TREE)
8301 from_len = rse->string_length;
8302 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8304 from_len = gfc_get_expr_charlen (re);
8305 gfc_init_se (&se, NULL);
8306 gfc_conv_expr (&se, re->ts.u.cl->length);
8307 gfc_add_block_to_block (block, &se.pre);
8308 gcc_assert (se.post.head == NULL_TREE);
8309 from_len = gfc_evaluate_now (se.expr, block);
8312 from_len = build_zero_cst (gfc_charlen_type_node);
8314 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8319 /* Return the _len trees only, when requested. */
8323 *from_lenp = from_len;
8328 /* Assign tokens for pointer components. */
8331 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8334 symbol_attribute lhs_attr, rhs_attr;
8335 tree tmp, lhs_tok, rhs_tok;
8336 /* Flag to indicated component refs on the rhs. */
8339 lhs_attr = gfc_caf_attr (expr1);
8340 if (expr2->expr_type != EXPR_NULL)
8342 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8343 if (lhs_attr.codimension && rhs_attr.codimension)
8345 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8346 lhs_tok = build_fold_indirect_ref (lhs_tok);
8349 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8353 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8354 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8357 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8359 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8360 gfc_prepend_expr_to_block (&lse->post, tmp);
8363 else if (lhs_attr.codimension)
8365 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8366 lhs_tok = build_fold_indirect_ref (lhs_tok);
8367 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8368 lhs_tok, null_pointer_node);
8369 gfc_prepend_expr_to_block (&lse->post, tmp);
8373 /* Indentify class valued proc_pointer assignments. */
8376 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8381 while (ref && ref->next)
8384 return ref && ref->type == REF_COMPONENT
8385 && ref->u.c.component->attr.proc_pointer
8386 && expr2->expr_type == EXPR_VARIABLE
8387 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8391 /* Do everything that is needed for a CLASS function expr2. */
8394 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8395 gfc_expr *expr1, gfc_expr *expr2)
8397 tree expr1_vptr = NULL_TREE;
8400 gfc_conv_function_expr (rse, expr2);
8401 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8403 if (expr1->ts.type != BT_CLASS)
8404 rse->expr = gfc_class_data_get (rse->expr);
8407 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8410 gfc_add_block_to_block (block, &rse->pre);
8411 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8412 gfc_add_modify (&lse->pre, tmp, rse->expr);
8414 gfc_add_modify (&lse->pre, expr1_vptr,
8415 fold_convert (TREE_TYPE (expr1_vptr),
8416 gfc_class_vptr_get (tmp)));
8417 rse->expr = gfc_class_data_get (tmp);
8425 gfc_trans_pointer_assign (gfc_code * code)
8427 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8431 /* Generate code for a pointer assignment. */
8434 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8441 tree expr1_vptr = NULL_TREE;
8442 bool scalar, non_proc_pointer_assign;
8445 gfc_start_block (&block);
8447 gfc_init_se (&lse, NULL);
8449 /* Usually testing whether this is not a proc pointer assignment. */
8450 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8452 /* Check whether the expression is a scalar or not; we cannot use
8453 expr1->rank as it can be nonzero for proc pointers. */
8454 ss = gfc_walk_expr (expr1);
8455 scalar = ss == gfc_ss_terminator;
8457 gfc_free_ss_chain (ss);
8459 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8460 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8462 gfc_add_data_component (expr2);
8463 /* The following is required as gfc_add_data_component doesn't
8464 update ts.type if there is a tailing REF_ARRAY. */
8465 expr2->ts.type = BT_DERIVED;
8470 /* Scalar pointers. */
8471 lse.want_pointer = 1;
8472 gfc_conv_expr (&lse, expr1);
8473 gfc_init_se (&rse, NULL);
8474 rse.want_pointer = 1;
8475 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8476 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8478 gfc_conv_expr (&rse, expr2);
8480 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8482 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8484 lse.expr = gfc_class_data_get (lse.expr);
8487 if (expr1->symtree->n.sym->attr.proc_pointer
8488 && expr1->symtree->n.sym->attr.dummy)
8489 lse.expr = build_fold_indirect_ref_loc (input_location,
8492 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8493 && expr2->symtree->n.sym->attr.dummy)
8494 rse.expr = build_fold_indirect_ref_loc (input_location,
8497 gfc_add_block_to_block (&block, &lse.pre);
8498 gfc_add_block_to_block (&block, &rse.pre);
8500 /* Check character lengths if character expression. The test is only
8501 really added if -fbounds-check is enabled. Exclude deferred
8502 character length lefthand sides. */
8503 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8504 && !expr1->ts.deferred
8505 && !expr1->symtree->n.sym->attr.proc_pointer
8506 && !gfc_is_proc_ptr_comp (expr1))
8508 gcc_assert (expr2->ts.type == BT_CHARACTER);
8509 gcc_assert (lse.string_length && rse.string_length);
8510 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8511 lse.string_length, rse.string_length,
8515 /* The assignment to an deferred character length sets the string
8516 length to that of the rhs. */
8517 if (expr1->ts.deferred)
8519 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8520 gfc_add_modify (&block, lse.string_length,
8521 fold_convert (TREE_TYPE (lse.string_length),
8522 rse.string_length));
8523 else if (lse.string_length != NULL)
8524 gfc_add_modify (&block, lse.string_length,
8525 build_zero_cst (TREE_TYPE (lse.string_length)));
8528 gfc_add_modify (&block, lse.expr,
8529 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8531 /* Also set the tokens for pointer components in derived typed
8533 if (flag_coarray == GFC_FCOARRAY_LIB)
8534 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8536 gfc_add_block_to_block (&block, &rse.post);
8537 gfc_add_block_to_block (&block, &lse.post);
8544 tree strlen_rhs = NULL_TREE;
8546 /* Array pointer. Find the last reference on the LHS and if it is an
8547 array section ref, we're dealing with bounds remapping. In this case,
8548 set it to AR_FULL so that gfc_conv_expr_descriptor does
8549 not see it and process the bounds remapping afterwards explicitly. */
8550 for (remap = expr1->ref; remap; remap = remap->next)
8551 if (!remap->next && remap->type == REF_ARRAY
8552 && remap->u.ar.type == AR_SECTION)
8554 rank_remap = (remap && remap->u.ar.end[0]);
8556 gfc_init_se (&lse, NULL);
8558 lse.descriptor_only = 1;
8559 gfc_conv_expr_descriptor (&lse, expr1);
8560 strlen_lhs = lse.string_length;
8563 if (expr2->expr_type == EXPR_NULL)
8565 /* Just set the data pointer to null. */
8566 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8568 else if (rank_remap)
8570 /* If we are rank-remapping, just get the RHS's descriptor and
8571 process this later on. */
8572 gfc_init_se (&rse, NULL);
8573 rse.direct_byref = 1;
8574 rse.byref_noassign = 1;
8576 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8577 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8579 else if (expr2->expr_type == EXPR_FUNCTION)
8581 tree bound[GFC_MAX_DIMENSIONS];
8584 for (i = 0; i < expr2->rank; i++)
8585 bound[i] = NULL_TREE;
8586 tmp = gfc_typenode_for_spec (&expr2->ts);
8587 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8589 GFC_ARRAY_POINTER_CONT, false);
8590 tmp = gfc_create_var (tmp, "ptrtemp");
8591 rse.descriptor_only = 0;
8593 rse.direct_byref = 1;
8594 gfc_conv_expr_descriptor (&rse, expr2);
8595 strlen_rhs = rse.string_length;
8600 gfc_conv_expr_descriptor (&rse, expr2);
8601 strlen_rhs = rse.string_length;
8602 if (expr1->ts.type == BT_CLASS)
8603 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8608 else if (expr2->expr_type == EXPR_VARIABLE)
8610 /* Assign directly to the LHS's descriptor. */
8611 lse.descriptor_only = 0;
8612 lse.direct_byref = 1;
8613 gfc_conv_expr_descriptor (&lse, expr2);
8614 strlen_rhs = lse.string_length;
8616 if (expr1->ts.type == BT_CLASS)
8618 rse.expr = NULL_TREE;
8619 rse.string_length = NULL_TREE;
8620 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8626 /* If the target is not a whole array, use the target array
8627 reference for remap. */
8628 for (remap = expr2->ref; remap; remap = remap->next)
8629 if (remap->type == REF_ARRAY
8630 && remap->u.ar.type == AR_FULL
8635 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8637 gfc_init_se (&rse, NULL);
8638 rse.want_pointer = 1;
8639 gfc_conv_function_expr (&rse, expr2);
8640 if (expr1->ts.type != BT_CLASS)
8642 rse.expr = gfc_class_data_get (rse.expr);
8643 gfc_add_modify (&lse.pre, desc, rse.expr);
8644 /* Set the lhs span. */
8645 tmp = TREE_TYPE (rse.expr);
8646 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8647 tmp = fold_convert (gfc_array_index_type, tmp);
8648 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8652 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8655 gfc_add_block_to_block (&block, &rse.pre);
8656 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8657 gfc_add_modify (&lse.pre, tmp, rse.expr);
8659 gfc_add_modify (&lse.pre, expr1_vptr,
8660 fold_convert (TREE_TYPE (expr1_vptr),
8661 gfc_class_vptr_get (tmp)));
8662 rse.expr = gfc_class_data_get (tmp);
8663 gfc_add_modify (&lse.pre, desc, rse.expr);
8668 /* Assign to a temporary descriptor and then copy that
8669 temporary to the pointer. */
8670 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8671 lse.descriptor_only = 0;
8673 lse.direct_byref = 1;
8674 gfc_conv_expr_descriptor (&lse, expr2);
8675 strlen_rhs = lse.string_length;
8676 gfc_add_modify (&lse.pre, desc, tmp);
8679 gfc_add_block_to_block (&block, &lse.pre);
8681 gfc_add_block_to_block (&block, &rse.pre);
8683 /* If we do bounds remapping, update LHS descriptor accordingly. */
8687 gcc_assert (remap->u.ar.dimen == expr1->rank);
8691 /* Do rank remapping. We already have the RHS's descriptor
8692 converted in rse and now have to build the correct LHS
8693 descriptor for it. */
8695 tree dtype, data, span;
8697 tree lbound, ubound;
8700 dtype = gfc_conv_descriptor_dtype (desc);
8701 tmp = gfc_get_dtype (TREE_TYPE (desc));
8702 gfc_add_modify (&block, dtype, tmp);
8704 /* Copy data pointer. */
8705 data = gfc_conv_descriptor_data_get (rse.expr);
8706 gfc_conv_descriptor_data_set (&block, desc, data);
8708 /* Copy the span. */
8709 if (TREE_CODE (rse.expr) == VAR_DECL
8710 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8711 span = gfc_conv_descriptor_span_get (rse.expr);
8714 tmp = TREE_TYPE (rse.expr);
8715 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8716 span = fold_convert (gfc_array_index_type, tmp);
8718 gfc_conv_descriptor_span_set (&block, desc, span);
8720 /* Copy offset but adjust it such that it would correspond
8721 to a lbound of zero. */
8722 offs = gfc_conv_descriptor_offset_get (rse.expr);
8723 for (dim = 0; dim < expr2->rank; ++dim)
8725 stride = gfc_conv_descriptor_stride_get (rse.expr,
8727 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8729 tmp = fold_build2_loc (input_location, MULT_EXPR,
8730 gfc_array_index_type, stride, lbound);
8731 offs = fold_build2_loc (input_location, PLUS_EXPR,
8732 gfc_array_index_type, offs, tmp);
8734 gfc_conv_descriptor_offset_set (&block, desc, offs);
8736 /* Set the bounds as declared for the LHS and calculate strides as
8737 well as another offset update accordingly. */
8738 stride = gfc_conv_descriptor_stride_get (rse.expr,
8740 for (dim = 0; dim < expr1->rank; ++dim)
8745 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8747 /* Convert declared bounds. */
8748 gfc_init_se (&lower_se, NULL);
8749 gfc_init_se (&upper_se, NULL);
8750 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8751 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8753 gfc_add_block_to_block (&block, &lower_se.pre);
8754 gfc_add_block_to_block (&block, &upper_se.pre);
8756 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8757 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8759 lbound = gfc_evaluate_now (lbound, &block);
8760 ubound = gfc_evaluate_now (ubound, &block);
8762 gfc_add_block_to_block (&block, &lower_se.post);
8763 gfc_add_block_to_block (&block, &upper_se.post);
8765 /* Set bounds in descriptor. */
8766 gfc_conv_descriptor_lbound_set (&block, desc,
8767 gfc_rank_cst[dim], lbound);
8768 gfc_conv_descriptor_ubound_set (&block, desc,
8769 gfc_rank_cst[dim], ubound);
8772 stride = gfc_evaluate_now (stride, &block);
8773 gfc_conv_descriptor_stride_set (&block, desc,
8774 gfc_rank_cst[dim], stride);
8776 /* Update offset. */
8777 offs = gfc_conv_descriptor_offset_get (desc);
8778 tmp = fold_build2_loc (input_location, MULT_EXPR,
8779 gfc_array_index_type, lbound, stride);
8780 offs = fold_build2_loc (input_location, MINUS_EXPR,
8781 gfc_array_index_type, offs, tmp);
8782 offs = gfc_evaluate_now (offs, &block);
8783 gfc_conv_descriptor_offset_set (&block, desc, offs);
8785 /* Update stride. */
8786 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8787 stride = fold_build2_loc (input_location, MULT_EXPR,
8788 gfc_array_index_type, stride, tmp);
8793 /* Bounds remapping. Just shift the lower bounds. */
8795 gcc_assert (expr1->rank == expr2->rank);
8797 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8801 gcc_assert (!remap->u.ar.end[dim]);
8802 gfc_init_se (&lbound_se, NULL);
8803 if (remap->u.ar.start[dim])
8805 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8806 gfc_add_block_to_block (&block, &lbound_se.pre);
8809 /* This remap arises from a target that is not a whole
8810 array. The start expressions will be NULL but we need
8811 the lbounds to be one. */
8812 lbound_se.expr = gfc_index_one_node;
8813 gfc_conv_shift_descriptor_lbound (&block, desc,
8814 dim, lbound_se.expr);
8815 gfc_add_block_to_block (&block, &lbound_se.post);
8820 /* Check string lengths if applicable. The check is only really added
8821 to the output code if -fbounds-check is enabled. */
8822 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8824 gcc_assert (expr2->ts.type == BT_CHARACTER);
8825 gcc_assert (strlen_lhs && strlen_rhs);
8826 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8827 strlen_lhs, strlen_rhs, &block);
8830 /* If rank remapping was done, check with -fcheck=bounds that
8831 the target is at least as large as the pointer. */
8832 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8838 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8839 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8841 lsize = gfc_evaluate_now (lsize, &block);
8842 rsize = gfc_evaluate_now (rsize, &block);
8843 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8846 msg = _("Target of rank remapping is too small (%ld < %ld)");
8847 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8851 gfc_add_block_to_block (&block, &lse.post);
8853 gfc_add_block_to_block (&block, &rse.post);
8856 return gfc_finish_block (&block);
8860 /* Makes sure se is suitable for passing as a function string parameter. */
8861 /* TODO: Need to check all callers of this function. It may be abused. */
8864 gfc_conv_string_parameter (gfc_se * se)
8868 if (TREE_CODE (se->expr) == STRING_CST)
8870 type = TREE_TYPE (TREE_TYPE (se->expr));
8871 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8875 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8877 if (TREE_CODE (se->expr) != INDIRECT_REF)
8879 type = TREE_TYPE (se->expr);
8880 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8884 type = gfc_get_character_type_len (gfc_default_character_kind,
8886 type = build_pointer_type (type);
8887 se->expr = gfc_build_addr_expr (type, se->expr);
8891 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8895 /* Generate code for assignment of scalar variables. Includes character
8896 strings and derived types with allocatable components.
8897 If you know that the LHS has no allocations, set dealloc to false.
8899 DEEP_COPY has no effect if the typespec TS is not a derived type with
8900 allocatable components. Otherwise, if it is set, an explicit copy of each
8901 allocatable component is made. This is necessary as a simple copy of the
8902 whole object would copy array descriptors as is, so that the lhs's
8903 allocatable components would point to the rhs's after the assignment.
8904 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8905 necessary if the rhs is a non-pointer function, as the allocatable components
8906 are not accessible by other means than the function's result after the
8907 function has returned. It is even more subtle when temporaries are involved,
8908 as the two following examples show:
8909 1. When we evaluate an array constructor, a temporary is created. Thus
8910 there is theoretically no alias possible. However, no deep copy is
8911 made for this temporary, so that if the constructor is made of one or
8912 more variable with allocatable components, those components still point
8913 to the variable's: DEEP_COPY should be set for the assignment from the
8914 temporary to the lhs in that case.
8915 2. When assigning a scalar to an array, we evaluate the scalar value out
8916 of the loop, store it into a temporary variable, and assign from that.
8917 In that case, deep copying when assigning to the temporary would be a
8918 waste of resources; however deep copies should happen when assigning from
8919 the temporary to each array element: again DEEP_COPY should be set for
8920 the assignment from the temporary to the lhs. */
8923 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
8924 bool deep_copy, bool dealloc, bool in_coarray)
8930 gfc_init_block (&block);
8932 if (ts.type == BT_CHARACTER)
8937 if (lse->string_length != NULL_TREE)
8939 gfc_conv_string_parameter (lse);
8940 gfc_add_block_to_block (&block, &lse->pre);
8941 llen = lse->string_length;
8944 if (rse->string_length != NULL_TREE)
8946 gfc_conv_string_parameter (rse);
8947 gfc_add_block_to_block (&block, &rse->pre);
8948 rlen = rse->string_length;
8951 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
8952 rse->expr, ts.kind);
8954 else if (gfc_bt_struct (ts.type)
8955 && (ts.u.derived->attr.alloc_comp
8956 || (deep_copy && ts.u.derived->attr.pdt_type)))
8958 tree tmp_var = NULL_TREE;
8961 /* Are the rhs and the lhs the same? */
8964 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8965 gfc_build_addr_expr (NULL_TREE, lse->expr),
8966 gfc_build_addr_expr (NULL_TREE, rse->expr));
8967 cond = gfc_evaluate_now (cond, &lse->pre);
8970 /* Deallocate the lhs allocated components as long as it is not
8971 the same as the rhs. This must be done following the assignment
8972 to prevent deallocating data that could be used in the rhs
8976 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
8977 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
8979 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8981 gfc_add_expr_to_block (&lse->post, tmp);
8984 gfc_add_block_to_block (&block, &rse->pre);
8985 gfc_add_block_to_block (&block, &lse->pre);
8987 gfc_add_modify (&block, lse->expr,
8988 fold_convert (TREE_TYPE (lse->expr), rse->expr));
8990 /* Restore pointer address of coarray components. */
8991 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
8993 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
8994 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
8996 gfc_add_expr_to_block (&block, tmp);
8999 /* Do a deep copy if the rhs is a variable, if it is not the
9003 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9004 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9005 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9007 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9009 gfc_add_expr_to_block (&block, tmp);
9012 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9014 gfc_add_block_to_block (&block, &lse->pre);
9015 gfc_add_block_to_block (&block, &rse->pre);
9016 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9017 TREE_TYPE (lse->expr), rse->expr);
9018 gfc_add_modify (&block, lse->expr, tmp);
9022 gfc_add_block_to_block (&block, &lse->pre);
9023 gfc_add_block_to_block (&block, &rse->pre);
9025 gfc_add_modify (&block, lse->expr,
9026 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9029 gfc_add_block_to_block (&block, &lse->post);
9030 gfc_add_block_to_block (&block, &rse->post);
9032 return gfc_finish_block (&block);
9036 /* There are quite a lot of restrictions on the optimisation in using an
9037 array function assign without a temporary. */
9040 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9043 bool seen_array_ref;
9045 gfc_symbol *sym = expr1->symtree->n.sym;
9047 /* Play it safe with class functions assigned to a derived type. */
9048 if (gfc_is_class_array_function (expr2)
9049 && expr1->ts.type == BT_DERIVED)
9052 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9053 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9056 /* Elemental functions are scalarized so that they don't need a
9057 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9058 they would need special treatment in gfc_trans_arrayfunc_assign. */
9059 if (expr2->value.function.esym != NULL
9060 && expr2->value.function.esym->attr.elemental)
9063 /* Need a temporary if rhs is not FULL or a contiguous section. */
9064 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9067 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9068 if (gfc_ref_needs_temporary_p (expr1->ref))
9071 /* Functions returning pointers or allocatables need temporaries. */
9072 c = expr2->value.function.esym
9073 ? (expr2->value.function.esym->attr.pointer
9074 || expr2->value.function.esym->attr.allocatable)
9075 : (expr2->symtree->n.sym->attr.pointer
9076 || expr2->symtree->n.sym->attr.allocatable);
9080 /* Character array functions need temporaries unless the
9081 character lengths are the same. */
9082 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9084 if (expr1->ts.u.cl->length == NULL
9085 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9088 if (expr2->ts.u.cl->length == NULL
9089 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9092 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9093 expr2->ts.u.cl->length->value.integer) != 0)
9097 /* Check that no LHS component references appear during an array
9098 reference. This is needed because we do not have the means to
9099 span any arbitrary stride with an array descriptor. This check
9100 is not needed for the rhs because the function result has to be
9102 seen_array_ref = false;
9103 for (ref = expr1->ref; ref; ref = ref->next)
9105 if (ref->type == REF_ARRAY)
9106 seen_array_ref= true;
9107 else if (ref->type == REF_COMPONENT && seen_array_ref)
9111 /* Check for a dependency. */
9112 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9113 expr2->value.function.esym,
9114 expr2->value.function.actual,
9118 /* If we have reached here with an intrinsic function, we do not
9119 need a temporary except in the particular case that reallocation
9120 on assignment is active and the lhs is allocatable and a target. */
9121 if (expr2->value.function.isym)
9122 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9124 /* If the LHS is a dummy, we need a temporary if it is not
9126 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9129 /* If the lhs has been host_associated, is in common, a pointer or is
9130 a target and the function is not using a RESULT variable, aliasing
9131 can occur and a temporary is needed. */
9132 if ((sym->attr.host_assoc
9133 || sym->attr.in_common
9134 || sym->attr.pointer
9135 || sym->attr.cray_pointee
9136 || sym->attr.target)
9137 && expr2->symtree != NULL
9138 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9141 /* A PURE function can unconditionally be called without a temporary. */
9142 if (expr2->value.function.esym != NULL
9143 && expr2->value.function.esym->attr.pure)
9146 /* Implicit_pure functions are those which could legally be declared
9148 if (expr2->value.function.esym != NULL
9149 && expr2->value.function.esym->attr.implicit_pure)
9152 if (!sym->attr.use_assoc
9153 && !sym->attr.in_common
9154 && !sym->attr.pointer
9155 && !sym->attr.target
9156 && !sym->attr.cray_pointee
9157 && expr2->value.function.esym)
9159 /* A temporary is not needed if the function is not contained and
9160 the variable is local or host associated and not a pointer or
9162 if (!expr2->value.function.esym->attr.contained)
9165 /* A temporary is not needed if the lhs has never been host
9166 associated and the procedure is contained. */
9167 else if (!sym->attr.host_assoc)
9170 /* A temporary is not needed if the variable is local and not
9171 a pointer, a target or a result. */
9173 && expr2->value.function.esym->ns == sym->ns->parent)
9177 /* Default to temporary use. */
9182 /* Provide the loop info so that the lhs descriptor can be built for
9183 reallocatable assignments from extrinsic function calls. */
9186 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9189 /* Signal that the function call should not be made by
9190 gfc_conv_loop_setup. */
9191 se->ss->is_alloc_lhs = 1;
9192 gfc_init_loopinfo (loop);
9193 gfc_add_ss_to_loop (loop, *ss);
9194 gfc_add_ss_to_loop (loop, se->ss);
9195 gfc_conv_ss_startstride (loop);
9196 gfc_conv_loop_setup (loop, where);
9197 gfc_copy_loopinfo_to_se (se, loop);
9198 gfc_add_block_to_block (&se->pre, &loop->pre);
9199 gfc_add_block_to_block (&se->pre, &loop->post);
9200 se->ss->is_alloc_lhs = 0;
9204 /* For assignment to a reallocatable lhs from intrinsic functions,
9205 replace the se.expr (ie. the result) with a temporary descriptor.
9206 Null the data field so that the library allocates space for the
9207 result. Free the data of the original descriptor after the function,
9208 in case it appears in an argument expression and transfer the
9209 result to the original descriptor. */
9212 fcncall_realloc_result (gfc_se *se, int rank)
9221 /* Use the allocation done by the library. Substitute the lhs
9222 descriptor with a copy, whose data field is nulled.*/
9223 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9224 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9225 desc = build_fold_indirect_ref_loc (input_location, desc);
9227 /* Unallocated, the descriptor does not have a dtype. */
9228 tmp = gfc_conv_descriptor_dtype (desc);
9229 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9231 res_desc = gfc_evaluate_now (desc, &se->pre);
9232 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9233 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9235 /* Free the lhs after the function call and copy the result data to
9236 the lhs descriptor. */
9237 tmp = gfc_conv_descriptor_data_get (desc);
9238 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9239 logical_type_node, tmp,
9240 build_int_cst (TREE_TYPE (tmp), 0));
9241 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9242 tmp = gfc_call_free (tmp);
9243 gfc_add_expr_to_block (&se->post, tmp);
9245 tmp = gfc_conv_descriptor_data_get (res_desc);
9246 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9248 /* Check that the shapes are the same between lhs and expression. */
9249 for (n = 0 ; n < rank; n++)
9252 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9253 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9254 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9255 gfc_array_index_type, tmp, tmp1);
9256 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9257 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9258 gfc_array_index_type, tmp, tmp1);
9259 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9260 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9261 gfc_array_index_type, tmp, tmp1);
9262 tmp = fold_build2_loc (input_location, NE_EXPR,
9263 logical_type_node, tmp,
9264 gfc_index_zero_node);
9265 tmp = gfc_evaluate_now (tmp, &se->post);
9266 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9267 logical_type_node, tmp,
9271 /* 'zero_cond' being true is equal to lhs not being allocated or the
9272 shapes being different. */
9273 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9275 /* Now reset the bounds returned from the function call to bounds based
9276 on the lhs lbounds, except where the lhs is not allocated or the shapes
9277 of 'variable and 'expr' are different. Set the offset accordingly. */
9278 offset = gfc_index_zero_node;
9279 for (n = 0 ; n < rank; n++)
9283 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9284 lbound = fold_build3_loc (input_location, COND_EXPR,
9285 gfc_array_index_type, zero_cond,
9286 gfc_index_one_node, lbound);
9287 lbound = gfc_evaluate_now (lbound, &se->post);
9289 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9290 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9291 gfc_array_index_type, tmp, lbound);
9292 gfc_conv_descriptor_lbound_set (&se->post, desc,
9293 gfc_rank_cst[n], lbound);
9294 gfc_conv_descriptor_ubound_set (&se->post, desc,
9295 gfc_rank_cst[n], tmp);
9297 /* Set stride and accumulate the offset. */
9298 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9299 gfc_conv_descriptor_stride_set (&se->post, desc,
9300 gfc_rank_cst[n], tmp);
9301 tmp = fold_build2_loc (input_location, MULT_EXPR,
9302 gfc_array_index_type, lbound, tmp);
9303 offset = fold_build2_loc (input_location, MINUS_EXPR,
9304 gfc_array_index_type, offset, tmp);
9305 offset = gfc_evaluate_now (offset, &se->post);
9308 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9313 /* Try to translate array(:) = func (...), where func is a transformational
9314 array function, without using a temporary. Returns NULL if this isn't the
9318 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9322 gfc_component *comp = NULL;
9325 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9328 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9330 comp = gfc_get_proc_ptr_comp (expr2);
9332 if (!(expr2->value.function.isym
9333 || (comp && comp->attr.dimension)
9334 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9335 && expr2->value.function.esym->result->attr.dimension)))
9338 gfc_init_se (&se, NULL);
9339 gfc_start_block (&se.pre);
9340 se.want_pointer = 1;
9342 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9344 if (expr1->ts.type == BT_DERIVED
9345 && expr1->ts.u.derived->attr.alloc_comp)
9348 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9350 gfc_add_expr_to_block (&se.pre, tmp);
9353 se.direct_byref = 1;
9354 se.ss = gfc_walk_expr (expr2);
9355 gcc_assert (se.ss != gfc_ss_terminator);
9357 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9358 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9359 Clearly, this cannot be done for an allocatable function result, since
9360 the shape of the result is unknown and, in any case, the function must
9361 correctly take care of the reallocation internally. For intrinsic
9362 calls, the array data is freed and the library takes care of allocation.
9363 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9365 if (flag_realloc_lhs
9366 && gfc_is_reallocatable_lhs (expr1)
9367 && !gfc_expr_attr (expr1).codimension
9368 && !gfc_is_coindexed (expr1)
9369 && !(expr2->value.function.esym
9370 && expr2->value.function.esym->result->attr.allocatable))
9372 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9374 if (!expr2->value.function.isym)
9376 ss = gfc_walk_expr (expr1);
9377 gcc_assert (ss != gfc_ss_terminator);
9379 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9380 ss->is_alloc_lhs = 1;
9383 fcncall_realloc_result (&se, expr1->rank);
9386 gfc_conv_function_expr (&se, expr2);
9387 gfc_add_block_to_block (&se.pre, &se.post);
9390 gfc_cleanup_loop (&loop);
9392 gfc_free_ss_chain (se.ss);
9394 return gfc_finish_block (&se.pre);
9398 /* Try to efficiently translate array(:) = 0. Return NULL if this
9402 gfc_trans_zero_assign (gfc_expr * expr)
9404 tree dest, len, type;
9408 sym = expr->symtree->n.sym;
9409 dest = gfc_get_symbol_decl (sym);
9411 type = TREE_TYPE (dest);
9412 if (POINTER_TYPE_P (type))
9413 type = TREE_TYPE (type);
9414 if (!GFC_ARRAY_TYPE_P (type))
9417 /* Determine the length of the array. */
9418 len = GFC_TYPE_ARRAY_SIZE (type);
9419 if (!len || TREE_CODE (len) != INTEGER_CST)
9422 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9423 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9424 fold_convert (gfc_array_index_type, tmp));
9426 /* If we are zeroing a local array avoid taking its address by emitting
9428 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9429 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9430 dest, build_constructor (TREE_TYPE (dest),
9433 /* Convert arguments to the correct types. */
9434 dest = fold_convert (pvoid_type_node, dest);
9435 len = fold_convert (size_type_node, len);
9437 /* Construct call to __builtin_memset. */
9438 tmp = build_call_expr_loc (input_location,
9439 builtin_decl_explicit (BUILT_IN_MEMSET),
9440 3, dest, integer_zero_node, len);
9441 return fold_convert (void_type_node, tmp);
9445 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9446 that constructs the call to __builtin_memcpy. */
9449 gfc_build_memcpy_call (tree dst, tree src, tree len)
9453 /* Convert arguments to the correct types. */
9454 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9455 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9457 dst = fold_convert (pvoid_type_node, dst);
9459 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9460 src = gfc_build_addr_expr (pvoid_type_node, src);
9462 src = fold_convert (pvoid_type_node, src);
9464 len = fold_convert (size_type_node, len);
9466 /* Construct call to __builtin_memcpy. */
9467 tmp = build_call_expr_loc (input_location,
9468 builtin_decl_explicit (BUILT_IN_MEMCPY),
9470 return fold_convert (void_type_node, tmp);
9474 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9475 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9476 source/rhs, both are gfc_full_array_ref_p which have been checked for
9480 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9482 tree dst, dlen, dtype;
9483 tree src, slen, stype;
9486 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9487 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9489 dtype = TREE_TYPE (dst);
9490 if (POINTER_TYPE_P (dtype))
9491 dtype = TREE_TYPE (dtype);
9492 stype = TREE_TYPE (src);
9493 if (POINTER_TYPE_P (stype))
9494 stype = TREE_TYPE (stype);
9496 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9499 /* Determine the lengths of the arrays. */
9500 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9501 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9503 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9504 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9505 dlen, fold_convert (gfc_array_index_type, tmp));
9507 slen = GFC_TYPE_ARRAY_SIZE (stype);
9508 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9510 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9511 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9512 slen, fold_convert (gfc_array_index_type, tmp));
9514 /* Sanity check that they are the same. This should always be
9515 the case, as we should already have checked for conformance. */
9516 if (!tree_int_cst_equal (slen, dlen))
9519 return gfc_build_memcpy_call (dst, src, dlen);
9523 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9524 this can't be done. EXPR1 is the destination/lhs for which
9525 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9528 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9530 unsigned HOST_WIDE_INT nelem;
9536 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9540 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9541 dtype = TREE_TYPE (dst);
9542 if (POINTER_TYPE_P (dtype))
9543 dtype = TREE_TYPE (dtype);
9544 if (!GFC_ARRAY_TYPE_P (dtype))
9547 /* Determine the lengths of the array. */
9548 len = GFC_TYPE_ARRAY_SIZE (dtype);
9549 if (!len || TREE_CODE (len) != INTEGER_CST)
9552 /* Confirm that the constructor is the same size. */
9553 if (compare_tree_int (len, nelem) != 0)
9556 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9557 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9558 fold_convert (gfc_array_index_type, tmp));
9560 stype = gfc_typenode_for_spec (&expr2->ts);
9561 src = gfc_build_constant_array_constructor (expr2, stype);
9563 stype = TREE_TYPE (src);
9564 if (POINTER_TYPE_P (stype))
9565 stype = TREE_TYPE (stype);
9567 return gfc_build_memcpy_call (dst, src, len);
9571 /* Tells whether the expression is to be treated as a variable reference. */
9574 gfc_expr_is_variable (gfc_expr *expr)
9577 gfc_component *comp;
9578 gfc_symbol *func_ifc;
9580 if (expr->expr_type == EXPR_VARIABLE)
9583 arg = gfc_get_noncopying_intrinsic_argument (expr);
9586 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9587 return gfc_expr_is_variable (arg);
9590 /* A data-pointer-returning function should be considered as a variable
9592 if (expr->expr_type == EXPR_FUNCTION
9593 && expr->ref == NULL)
9595 if (expr->value.function.isym != NULL)
9598 if (expr->value.function.esym != NULL)
9600 func_ifc = expr->value.function.esym;
9605 gcc_assert (expr->symtree);
9606 func_ifc = expr->symtree->n.sym;
9613 comp = gfc_get_proc_ptr_comp (expr);
9614 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9617 func_ifc = comp->ts.interface;
9621 if (expr->expr_type == EXPR_COMPCALL)
9623 gcc_assert (!expr->value.compcall.tbp->is_generic);
9624 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9631 gcc_assert (func_ifc->attr.function
9632 && func_ifc->result != NULL);
9633 return func_ifc->result->attr.pointer;
9637 /* Is the lhs OK for automatic reallocation? */
9640 is_scalar_reallocatable_lhs (gfc_expr *expr)
9644 /* An allocatable variable with no reference. */
9645 if (expr->symtree->n.sym->attr.allocatable
9649 /* All that can be left are allocatable components. However, we do
9650 not check for allocatable components here because the expression
9651 could be an allocatable component of a pointer component. */
9652 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9653 && expr->symtree->n.sym->ts.type != BT_CLASS)
9656 /* Find an allocatable component ref last. */
9657 for (ref = expr->ref; ref; ref = ref->next)
9658 if (ref->type == REF_COMPONENT
9660 && ref->u.c.component->attr.allocatable)
9667 /* Allocate or reallocate scalar lhs, as necessary. */
9670 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9685 if (!expr1 || expr1->rank)
9688 if (!expr2 || expr2->rank)
9691 for (ref = expr1->ref; ref; ref = ref->next)
9692 if (ref->type == REF_SUBSTRING)
9695 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9697 /* Since this is a scalar lhs, we can afford to do this. That is,
9698 there is no risk of side effects being repeated. */
9699 gfc_init_se (&lse, NULL);
9700 lse.want_pointer = 1;
9701 gfc_conv_expr (&lse, expr1);
9703 jump_label1 = gfc_build_label_decl (NULL_TREE);
9704 jump_label2 = gfc_build_label_decl (NULL_TREE);
9706 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9707 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9708 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9710 tmp = build3_v (COND_EXPR, cond,
9711 build1_v (GOTO_EXPR, jump_label1),
9712 build_empty_stmt (input_location));
9713 gfc_add_expr_to_block (block, tmp);
9715 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9717 /* Use the rhs string length and the lhs element size. */
9718 size = string_length;
9719 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9720 tmp = TYPE_SIZE_UNIT (tmp);
9721 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9722 TREE_TYPE (tmp), tmp,
9723 fold_convert (TREE_TYPE (tmp), size));
9727 /* Otherwise use the length in bytes of the rhs. */
9728 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9729 size_in_bytes = size;
9732 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9733 size_in_bytes, size_one_node);
9735 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9737 tree caf_decl, token;
9739 symbol_attribute attr;
9741 gfc_clear_attr (&attr);
9742 gfc_init_se (&caf_se, NULL);
9744 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9745 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9747 gfc_add_block_to_block (block, &caf_se.pre);
9748 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9749 gfc_build_addr_expr (NULL_TREE, token),
9750 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9753 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9755 tmp = build_call_expr_loc (input_location,
9756 builtin_decl_explicit (BUILT_IN_CALLOC),
9757 2, build_one_cst (size_type_node),
9759 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9760 gfc_add_modify (block, lse.expr, tmp);
9764 tmp = build_call_expr_loc (input_location,
9765 builtin_decl_explicit (BUILT_IN_MALLOC),
9767 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9768 gfc_add_modify (block, lse.expr, tmp);
9771 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9773 /* Deferred characters need checking for lhs and rhs string
9774 length. Other deferred parameter variables will have to
9776 tmp = build1_v (GOTO_EXPR, jump_label2);
9777 gfc_add_expr_to_block (block, tmp);
9779 tmp = build1_v (LABEL_EXPR, jump_label1);
9780 gfc_add_expr_to_block (block, tmp);
9782 /* For a deferred length character, reallocate if lengths of lhs and
9783 rhs are different. */
9784 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9786 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9788 fold_convert (TREE_TYPE (lse.string_length),
9790 /* Jump past the realloc if the lengths are the same. */
9791 tmp = build3_v (COND_EXPR, cond,
9792 build1_v (GOTO_EXPR, jump_label2),
9793 build_empty_stmt (input_location));
9794 gfc_add_expr_to_block (block, tmp);
9795 tmp = build_call_expr_loc (input_location,
9796 builtin_decl_explicit (BUILT_IN_REALLOC),
9797 2, fold_convert (pvoid_type_node, lse.expr),
9799 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9800 gfc_add_modify (block, lse.expr, tmp);
9801 tmp = build1_v (LABEL_EXPR, jump_label2);
9802 gfc_add_expr_to_block (block, tmp);
9804 /* Update the lhs character length. */
9805 size = string_length;
9806 gfc_add_modify (block, lse.string_length,
9807 fold_convert (TREE_TYPE (lse.string_length), size));
9811 /* Check for assignments of the type
9815 to make sure we do not check for reallocation unneccessarily. */
9819 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9821 gfc_actual_arglist *a;
9824 switch (expr2->expr_type)
9827 return gfc_dep_compare_expr (expr1, expr2) == 0;
9830 if (expr2->value.function.esym
9831 && expr2->value.function.esym->attr.elemental)
9833 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9836 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9841 else if (expr2->value.function.isym
9842 && expr2->value.function.isym->elemental)
9844 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9847 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9856 switch (expr2->value.op.op)
9859 case INTRINSIC_UPLUS:
9860 case INTRINSIC_UMINUS:
9861 case INTRINSIC_PARENTHESES:
9862 return is_runtime_conformable (expr1, expr2->value.op.op1);
9864 case INTRINSIC_PLUS:
9865 case INTRINSIC_MINUS:
9866 case INTRINSIC_TIMES:
9867 case INTRINSIC_DIVIDE:
9868 case INTRINSIC_POWER:
9872 case INTRINSIC_NEQV:
9879 case INTRINSIC_EQ_OS:
9880 case INTRINSIC_NE_OS:
9881 case INTRINSIC_GT_OS:
9882 case INTRINSIC_GE_OS:
9883 case INTRINSIC_LT_OS:
9884 case INTRINSIC_LE_OS:
9886 e1 = expr2->value.op.op1;
9887 e2 = expr2->value.op.op2;
9889 if (e1->rank == 0 && e2->rank > 0)
9890 return is_runtime_conformable (expr1, e2);
9891 else if (e1->rank > 0 && e2->rank == 0)
9892 return is_runtime_conformable (expr1, e1);
9893 else if (e1->rank > 0 && e2->rank > 0)
9894 return is_runtime_conformable (expr1, e1)
9895 && is_runtime_conformable (expr1, e2);
9913 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9914 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9917 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9918 vec<tree, va_gc> *args = NULL;
9920 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9923 /* Generate allocation of the lhs. */
9929 tmp = gfc_vptr_size_get (vptr);
9930 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9931 ? gfc_class_data_get (lse->expr) : lse->expr;
9932 gfc_init_block (&alloc);
9933 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
9934 tmp = fold_build2_loc (input_location, EQ_EXPR,
9935 logical_type_node, class_han,
9936 build_int_cst (prvoid_type_node, 0));
9937 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
9939 PRED_FORTRAN_FAIL_ALLOC),
9940 gfc_finish_block (&alloc),
9941 build_empty_stmt (input_location));
9942 gfc_add_expr_to_block (&lse->pre, tmp);
9945 fcn = gfc_vptr_copy_get (vptr);
9947 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
9948 ? gfc_class_data_get (rse->expr) : rse->expr;
9951 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9952 || INDIRECT_REF_P (tmp)
9953 || (rhs->ts.type == BT_DERIVED
9954 && rhs->ts.u.derived->attr.unlimited_polymorphic
9955 && !rhs->ts.u.derived->attr.pointer
9956 && !rhs->ts.u.derived->attr.allocatable)
9957 || (UNLIMITED_POLY (rhs)
9958 && !CLASS_DATA (rhs)->attr.pointer
9959 && !CLASS_DATA (rhs)->attr.allocatable))
9960 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9962 vec_safe_push (args, tmp);
9963 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9964 ? gfc_class_data_get (lse->expr) : lse->expr;
9965 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9966 || INDIRECT_REF_P (tmp)
9967 || (lhs->ts.type == BT_DERIVED
9968 && lhs->ts.u.derived->attr.unlimited_polymorphic
9969 && !lhs->ts.u.derived->attr.pointer
9970 && !lhs->ts.u.derived->attr.allocatable)
9971 || (UNLIMITED_POLY (lhs)
9972 && !CLASS_DATA (lhs)->attr.pointer
9973 && !CLASS_DATA (lhs)->attr.allocatable))
9974 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9976 vec_safe_push (args, tmp);
9978 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9980 if (to_len != NULL_TREE && !integer_zerop (from_len))
9983 vec_safe_push (args, from_len);
9984 vec_safe_push (args, to_len);
9985 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
9987 tmp = fold_build2_loc (input_location, GT_EXPR,
9988 logical_type_node, from_len,
9989 build_zero_cst (TREE_TYPE (from_len)));
9990 return fold_build3_loc (input_location, COND_EXPR,
9991 void_type_node, tmp,
9999 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10000 ? gfc_class_data_get (lse->expr) : lse->expr;
10001 stmtblock_t tblock;
10002 gfc_init_block (&tblock);
10003 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10004 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10005 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10006 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10007 /* When coming from a ptr_copy lhs and rhs are swapped. */
10008 gfc_add_modify_loc (input_location, &tblock, rhst,
10009 fold_convert (TREE_TYPE (rhst), tmp));
10010 return gfc_finish_block (&tblock);
10014 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10015 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10016 init_flag indicates initialization expressions and dealloc that no
10017 deallocate prior assignment is needed (if in doubt, set true).
10018 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10019 routine instead of a pointer assignment. Alias resolution is only done,
10020 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10021 where it is known, that newly allocated memory on the lhs can never be
10022 an alias of the rhs. */
10025 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10026 bool dealloc, bool use_vptr_copy, bool may_alias)
10031 gfc_ss *lss_section;
10038 bool scalar_to_array;
10039 tree string_length;
10041 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10042 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10043 bool is_poly_assign;
10045 /* Assignment of the form lhs = rhs. */
10046 gfc_start_block (&block);
10048 gfc_init_se (&lse, NULL);
10049 gfc_init_se (&rse, NULL);
10051 /* Walk the lhs. */
10052 lss = gfc_walk_expr (expr1);
10053 if (gfc_is_reallocatable_lhs (expr1))
10055 lss->no_bounds_check = 1;
10056 if (!(expr2->expr_type == EXPR_FUNCTION
10057 && expr2->value.function.isym != NULL
10058 && !(expr2->value.function.isym->elemental
10059 || expr2->value.function.isym->conversion)))
10060 lss->is_alloc_lhs = 1;
10063 lss->no_bounds_check = expr1->no_bounds_check;
10067 if ((expr1->ts.type == BT_DERIVED)
10068 && (gfc_is_class_array_function (expr2)
10069 || gfc_is_alloc_class_scalar_function (expr2)))
10070 expr2->must_finalize = 1;
10072 /* Checking whether a class assignment is desired is quite complicated and
10073 needed at two locations, so do it once only before the information is
10075 lhs_attr = gfc_expr_attr (expr1);
10076 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10077 || (lhs_attr.allocatable && !lhs_attr.dimension))
10078 && (expr1->ts.type == BT_CLASS
10079 || gfc_is_class_array_ref (expr1, NULL)
10080 || gfc_is_class_scalar_expr (expr1)
10081 || gfc_is_class_array_ref (expr2, NULL)
10082 || gfc_is_class_scalar_expr (expr2));
10085 /* Only analyze the expressions for coarray properties, when in coarray-lib
10087 if (flag_coarray == GFC_FCOARRAY_LIB)
10089 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10090 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10093 if (lss != gfc_ss_terminator)
10095 /* The assignment needs scalarization. */
10098 /* Find a non-scalar SS from the lhs. */
10099 while (lss_section != gfc_ss_terminator
10100 && lss_section->info->type != GFC_SS_SECTION)
10101 lss_section = lss_section->next;
10103 gcc_assert (lss_section != gfc_ss_terminator);
10105 /* Initialize the scalarizer. */
10106 gfc_init_loopinfo (&loop);
10108 /* Walk the rhs. */
10109 rss = gfc_walk_expr (expr2);
10110 if (rss == gfc_ss_terminator)
10111 /* The rhs is scalar. Add a ss for the expression. */
10112 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10113 /* When doing a class assign, then the handle to the rhs needs to be a
10114 pointer to allow for polymorphism. */
10115 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10116 rss->info->type = GFC_SS_REFERENCE;
10118 rss->no_bounds_check = expr2->no_bounds_check;
10119 /* Associate the SS with the loop. */
10120 gfc_add_ss_to_loop (&loop, lss);
10121 gfc_add_ss_to_loop (&loop, rss);
10123 /* Calculate the bounds of the scalarization. */
10124 gfc_conv_ss_startstride (&loop);
10125 /* Enable loop reversal. */
10126 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10127 loop.reverse[n] = GFC_ENABLE_REVERSE;
10128 /* Resolve any data dependencies in the statement. */
10130 gfc_conv_resolve_dependencies (&loop, lss, rss);
10131 /* Setup the scalarizing loops. */
10132 gfc_conv_loop_setup (&loop, &expr2->where);
10134 /* Setup the gfc_se structures. */
10135 gfc_copy_loopinfo_to_se (&lse, &loop);
10136 gfc_copy_loopinfo_to_se (&rse, &loop);
10139 gfc_mark_ss_chain_used (rss, 1);
10140 if (loop.temp_ss == NULL)
10143 gfc_mark_ss_chain_used (lss, 1);
10147 lse.ss = loop.temp_ss;
10148 gfc_mark_ss_chain_used (lss, 3);
10149 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10152 /* Allow the scalarizer to workshare array assignments. */
10153 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10154 == OMPWS_WORKSHARE_FLAG
10155 && loop.temp_ss == NULL)
10157 maybe_workshare = true;
10158 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10161 /* Start the scalarized loop body. */
10162 gfc_start_scalarized_body (&loop, &body);
10165 gfc_init_block (&body);
10167 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10169 /* Translate the expression. */
10170 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10171 && lhs_caf_attr.codimension;
10172 gfc_conv_expr (&rse, expr2);
10174 /* Deal with the case of a scalar class function assigned to a derived type. */
10175 if (gfc_is_alloc_class_scalar_function (expr2)
10176 && expr1->ts.type == BT_DERIVED)
10178 rse.expr = gfc_class_data_get (rse.expr);
10179 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10182 /* Stabilize a string length for temporaries. */
10183 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10184 && !(VAR_P (rse.string_length)
10185 || TREE_CODE (rse.string_length) == PARM_DECL
10186 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10187 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10188 else if (expr2->ts.type == BT_CHARACTER)
10189 string_length = rse.string_length;
10191 string_length = NULL_TREE;
10195 gfc_conv_tmp_array_ref (&lse);
10196 if (expr2->ts.type == BT_CHARACTER)
10197 lse.string_length = string_length;
10201 gfc_conv_expr (&lse, expr1);
10202 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10204 && gfc_expr_attr (expr1).allocatable
10211 tmp = INDIRECT_REF_P (lse.expr)
10212 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10214 /* We should only get array references here. */
10215 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10216 || TREE_CODE (tmp) == ARRAY_REF);
10218 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10219 or the array itself(ARRAY_REF). */
10220 tmp = TREE_OPERAND (tmp, 0);
10222 /* Provide the address of the array. */
10223 if (TREE_CODE (lse.expr) == ARRAY_REF)
10224 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10226 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10227 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10228 msg = _("Assignment of scalar to unallocated array");
10229 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10230 &expr1->where, msg);
10233 /* Deallocate the lhs parameterized components if required. */
10234 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10235 && !expr1->symtree->n.sym->attr.associate_var)
10237 if (expr1->ts.type == BT_DERIVED
10238 && expr1->ts.u.derived
10239 && expr1->ts.u.derived->attr.pdt_type)
10241 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10243 gfc_add_expr_to_block (&lse.pre, tmp);
10245 else if (expr1->ts.type == BT_CLASS
10246 && CLASS_DATA (expr1)->ts.u.derived
10247 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10249 tmp = gfc_class_data_get (lse.expr);
10250 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10252 gfc_add_expr_to_block (&lse.pre, tmp);
10257 /* Assignments of scalar derived types with allocatable components
10258 to arrays must be done with a deep copy and the rhs temporary
10259 must have its components deallocated afterwards. */
10260 scalar_to_array = (expr2->ts.type == BT_DERIVED
10261 && expr2->ts.u.derived->attr.alloc_comp
10262 && !gfc_expr_is_variable (expr2)
10263 && expr1->rank && !expr2->rank);
10264 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10266 && expr1->ts.u.derived->attr.alloc_comp
10267 && gfc_is_alloc_class_scalar_function (expr2));
10268 if (scalar_to_array && dealloc)
10270 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10271 gfc_prepend_expr_to_block (&loop.post, tmp);
10274 /* When assigning a character function result to a deferred-length variable,
10275 the function call must happen before the (re)allocation of the lhs -
10276 otherwise the character length of the result is not known.
10277 NOTE: This relies on having the exact dependence of the length type
10278 parameter available to the caller; gfortran saves it in the .mod files.
10279 NOTE ALSO: The concatenation operation generates a temporary pointer,
10280 whose allocation must go to the innermost loop.
10281 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10282 if (flag_realloc_lhs
10283 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10284 && !(lss != gfc_ss_terminator
10285 && ((expr2->expr_type == EXPR_OP
10286 && expr2->value.op.op == INTRINSIC_CONCAT)
10287 || (expr2->expr_type == EXPR_FUNCTION
10288 && expr2->value.function.isym != NULL
10289 && expr2->value.function.isym->id == GFC_ISYM_CONVERSION))))
10290 gfc_add_block_to_block (&block, &rse.pre);
10292 /* Nullify the allocatable components corresponding to those of the lhs
10293 derived type, so that the finalization of the function result does not
10294 affect the lhs of the assignment. Prepend is used to ensure that the
10295 nullification occurs before the call to the finalizer. In the case of
10296 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10297 as part of the deep copy. */
10298 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10299 && (gfc_is_class_array_function (expr2)
10300 || gfc_is_alloc_class_scalar_function (expr2)))
10303 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10304 gfc_prepend_expr_to_block (&rse.post, tmp);
10305 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10306 gfc_add_block_to_block (&loop.post, &rse.post);
10311 if (is_poly_assign)
10312 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10313 use_vptr_copy || (lhs_attr.allocatable
10314 && !lhs_attr.dimension),
10315 flag_realloc_lhs && !lhs_attr.pointer);
10316 else if (flag_coarray == GFC_FCOARRAY_LIB
10317 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10318 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10319 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10321 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10322 allocatable component, because those need to be accessed via the
10323 caf-runtime. No need to check for coindexes here, because resolve
10324 has rewritten those already. */
10326 gfc_actual_arglist a1, a2;
10327 /* Clear the structures to prevent accessing garbage. */
10328 memset (&code, '\0', sizeof (gfc_code));
10329 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10330 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10335 code.ext.actual = &a1;
10336 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10337 tmp = gfc_conv_intrinsic_subroutine (&code);
10339 else if (!is_poly_assign && expr2->must_finalize
10340 && expr1->ts.type == BT_CLASS
10341 && expr2->ts.type == BT_CLASS)
10343 /* This case comes about when the scalarizer provides array element
10344 references. Use the vptr copy function, since this does a deep
10345 copy of allocatable components, without which the finalizer call */
10346 tmp = gfc_get_vptr_from_expr (rse.expr);
10347 if (tmp != NULL_TREE)
10349 tree fcn = gfc_vptr_copy_get (tmp);
10350 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10351 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10352 tmp = build_call_expr_loc (input_location,
10354 gfc_build_addr_expr (NULL, rse.expr),
10355 gfc_build_addr_expr (NULL, lse.expr));
10359 /* If nothing else works, do it the old fashioned way! */
10360 if (tmp == NULL_TREE)
10361 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10362 gfc_expr_is_variable (expr2)
10364 || expr2->expr_type == EXPR_ARRAY,
10365 !(l_is_temp || init_flag) && dealloc,
10366 expr1->symtree->n.sym->attr.codimension);
10368 /* Add the pre blocks to the body. */
10369 gfc_add_block_to_block (&body, &rse.pre);
10370 gfc_add_block_to_block (&body, &lse.pre);
10371 gfc_add_expr_to_block (&body, tmp);
10372 /* Add the post blocks to the body. */
10373 gfc_add_block_to_block (&body, &rse.post);
10374 gfc_add_block_to_block (&body, &lse.post);
10376 if (lss == gfc_ss_terminator)
10378 /* F2003: Add the code for reallocation on assignment. */
10379 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10380 && !is_poly_assign)
10381 alloc_scalar_allocatable_for_assignment (&block, string_length,
10384 /* Use the scalar assignment as is. */
10385 gfc_add_block_to_block (&block, &body);
10389 gcc_assert (lse.ss == gfc_ss_terminator
10390 && rse.ss == gfc_ss_terminator);
10394 gfc_trans_scalarized_loop_boundary (&loop, &body);
10396 /* We need to copy the temporary to the actual lhs. */
10397 gfc_init_se (&lse, NULL);
10398 gfc_init_se (&rse, NULL);
10399 gfc_copy_loopinfo_to_se (&lse, &loop);
10400 gfc_copy_loopinfo_to_se (&rse, &loop);
10402 rse.ss = loop.temp_ss;
10405 gfc_conv_tmp_array_ref (&rse);
10406 gfc_conv_expr (&lse, expr1);
10408 gcc_assert (lse.ss == gfc_ss_terminator
10409 && rse.ss == gfc_ss_terminator);
10411 if (expr2->ts.type == BT_CHARACTER)
10412 rse.string_length = string_length;
10414 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10416 gfc_add_expr_to_block (&body, tmp);
10419 /* F2003: Allocate or reallocate lhs of allocatable array. */
10420 if (flag_realloc_lhs
10421 && gfc_is_reallocatable_lhs (expr1)
10423 && !is_runtime_conformable (expr1, expr2))
10425 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10426 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10427 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10428 if (tmp != NULL_TREE)
10429 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10432 if (maybe_workshare)
10433 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10435 /* Generate the copying loops. */
10436 gfc_trans_scalarizing_loops (&loop, &body);
10438 /* Wrap the whole thing up. */
10439 gfc_add_block_to_block (&block, &loop.pre);
10440 gfc_add_block_to_block (&block, &loop.post);
10442 gfc_cleanup_loop (&loop);
10445 return gfc_finish_block (&block);
10449 /* Check whether EXPR is a copyable array. */
10452 copyable_array_p (gfc_expr * expr)
10454 if (expr->expr_type != EXPR_VARIABLE)
10457 /* First check it's an array. */
10458 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10461 if (!gfc_full_array_ref_p (expr->ref, NULL))
10464 /* Next check that it's of a simple enough type. */
10465 switch (expr->ts.type)
10477 return !expr->ts.u.derived->attr.alloc_comp;
10486 /* Translate an assignment. */
10489 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10490 bool dealloc, bool use_vptr_copy, bool may_alias)
10494 /* Special case a single function returning an array. */
10495 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10497 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10502 /* Special case assigning an array to zero. */
10503 if (copyable_array_p (expr1)
10504 && is_zero_initializer_p (expr2))
10506 tmp = gfc_trans_zero_assign (expr1);
10511 /* Special case copying one array to another. */
10512 if (copyable_array_p (expr1)
10513 && copyable_array_p (expr2)
10514 && gfc_compare_types (&expr1->ts, &expr2->ts)
10515 && !gfc_check_dependency (expr1, expr2, 0))
10517 tmp = gfc_trans_array_copy (expr1, expr2);
10522 /* Special case initializing an array from a constant array constructor. */
10523 if (copyable_array_p (expr1)
10524 && expr2->expr_type == EXPR_ARRAY
10525 && gfc_compare_types (&expr1->ts, &expr2->ts))
10527 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10532 if (UNLIMITED_POLY (expr1) && expr1->rank
10533 && expr2->ts.type != BT_CLASS)
10534 use_vptr_copy = true;
10536 /* Fallback to the scalarizer to generate explicit loops. */
10537 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10538 use_vptr_copy, may_alias);
10542 gfc_trans_init_assign (gfc_code * code)
10544 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10548 gfc_trans_assign (gfc_code * code)
10550 return gfc_trans_assignment (code->expr1, code->expr2, false, true);