1 /* Expression translation
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
51 enum gfc_array_kind akind;
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
61 scalar = TREE_TYPE (scalar);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
63 akind, !(attr.pointer || attr.target));
67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
69 tree desc, type, etype;
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 etype = TREE_TYPE (scalar);
73 desc = gfc_create_var (type, "desc");
74 DECL_ARTIFICIAL (desc) = 1;
76 if (CONSTANT_CLASS_P (scalar))
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
84 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
85 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
86 etype = TREE_TYPE (etype);
87 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
88 gfc_get_dtype_rank_type (0, etype));
89 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
94 gfc_add_modify (&se->post, scalar,
95 fold_convert (TREE_TYPE (scalar),
96 gfc_conv_descriptor_data_get (desc)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
107 gfc_symbol *sym = expr->symtree->n.sym;
108 bool is_coarray = sym->attr.codimension;
109 gfc_expr *caf_expr = gfc_copy_expr (expr);
110 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
114 if (ref->type == REF_COMPONENT
115 && (ref->u.c.component->attr.allocatable
116 || ref->u.c.component->attr.pointer)
117 && (is_coarray || ref->u.c.component->attr.codimension))
122 if (last_caf_ref == NULL)
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
130 gfc_init_se (&se, outerse);
131 gfc_free_ref_list (last_caf_ref->next);
132 last_caf_ref->next = NULL;
133 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
134 se.want_pointer = comp_ref;
135 gfc_conv_expr (&se, caf_expr);
136 gfc_add_block_to_block (&outerse->pre, &se.pre);
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
172 vec<constructor_elt, va_gc> *init = NULL;
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
181 return build_constructor (TREE_TYPE (decl), init);
186 gfc_class_data_get (tree decl)
189 if (POINTER_TYPE_P (TREE_TYPE (decl)))
190 decl = build_fold_indirect_ref_loc (input_location, decl);
191 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
200 gfc_class_vptr_get (tree decl)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl))
207 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
208 if (POINTER_TYPE_P (TREE_TYPE (decl)))
209 decl = build_fold_indirect_ref_loc (input_location, decl);
210 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
219 gfc_class_len_get (tree decl)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl))
226 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
227 if (POINTER_TYPE_P (TREE_TYPE (decl)))
228 decl = build_fold_indirect_ref_loc (input_location, decl);
229 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
256 : build_zero_cst (gfc_charlen_type_node);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr, int fieldno)
266 vptr = build_fold_indirect_ref_loc (input_location, vptr);
267 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
269 field = fold_build3_loc (input_location, COMPONENT_REF,
270 TREE_TYPE (field), vptr, field,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl, int fieldno)
283 vptr = gfc_class_vptr_get (decl);
284 return vptr_field_get (vptr, fieldno);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
303 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
304 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
305 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
306 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
307 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl)
317 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
318 /* Always return size as an array index type. */
319 size = fold_convert (gfc_array_index_type, size);
325 gfc_vptr_size_get (tree vptr)
328 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
329 /* Always return size as an array index type. */
330 size = fold_convert (gfc_array_index_type, size);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
358 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
360 /* Find the last class reference. */
363 for (ref = e->ref; ref; ref = ref->next)
365 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
368 if (ref->type == REF_COMPONENT
369 && ref->u.c.component->ts.type == BT_CLASS)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
380 if (ref->next == NULL)
384 /* Remove and store all subsequent references after the
388 tail = class_ref->next;
389 class_ref->next = NULL;
391 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
397 base_expr = gfc_copy_expr (e);
399 /* Restore the original tail expression. */
402 gfc_free_ref_list (class_ref->next);
403 class_ref->next = tail;
405 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
407 gfc_free_ref_list (e->ref);
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
417 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se, NULL);
427 gfc_conv_expr_descriptor (&se, e);
429 gfc_conv_expr (&se, e);
430 gfc_add_block_to_block (block, &se.pre);
431 vptr = gfc_get_vptr_from_expr (se.expr);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr == NULL_TREE)
437 if (UNLIMITED_POLY (e))
438 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
441 /* Return the vptr to the address of the declared type. */
442 vtab = gfc_find_derived_vtab (e->ts.u.derived);
443 vtable = vtab->backend_decl;
444 if (vtable == NULL_TREE)
445 vtable = gfc_get_symbol_decl (vtab);
446 vtable = gfc_build_addr_expr (NULL, vtable);
447 vtable = fold_convert (TREE_TYPE (vptr), vtable);
448 gfc_add_modify (block, vptr, vtable);
453 /* Reset the len for unlimited polymorphic objects. */
456 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
460 e = gfc_find_and_cut_at_last_class_ref (expr);
463 gfc_add_len_component (e);
464 gfc_init_se (&se_len, NULL);
465 gfc_conv_expr (&se_len, e);
466 gfc_add_modify (block, se_len.expr,
467 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
476 gfc_get_vptr_from_expr (tree expr)
481 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
483 type = TREE_TYPE (tmp);
486 if (GFC_CLASS_TYPE_P (type))
487 return gfc_class_vptr_get (tmp);
488 if (type != TYPE_CANONICAL (type))
489 type = TYPE_CANONICAL (type);
493 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
497 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
498 tmp = build_fold_indirect_ref_loc (input_location, tmp);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
501 return gfc_class_vptr_get (tmp);
508 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
511 tree tmp, tmp2, type;
513 gfc_conv_descriptor_data_set (block, lhs_desc,
514 gfc_conv_descriptor_data_get (rhs_desc));
515 gfc_conv_descriptor_offset_set (block, lhs_desc,
516 gfc_conv_descriptor_offset_get (rhs_desc));
518 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
519 gfc_conv_descriptor_dtype (rhs_desc));
521 /* Assign the dimension as range-ref. */
522 tmp = gfc_get_descriptor_dimension (lhs_desc);
523 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
525 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
526 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
527 gfc_index_zero_node, NULL_TREE, NULL_TREE);
528 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
529 gfc_index_zero_node, NULL_TREE, NULL_TREE);
530 gfc_add_modify (block, tmp, tmp2);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
540 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
541 gfc_typespec class_ts, tree vptr, bool optional,
542 bool optional_alloc_ptr)
545 tree cond_optional = NULL_TREE;
552 /* The derived type needs to be converted to a temporary
554 tmp = gfc_typenode_for_spec (&class_ts);
555 var = gfc_create_var (tmp, "class");
558 ctree = gfc_class_vptr_get (var);
560 if (vptr != NULL_TREE)
562 /* Use the dynamic vptr. */
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab = gfc_find_derived_vtab (e->ts.u.derived);
571 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
573 gfc_add_modify (&parmse->pre, ctree,
574 fold_convert (TREE_TYPE (ctree), tmp));
576 /* Now set the data field. */
577 ctree = gfc_class_data_get (var);
580 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
582 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
587 gfc_add_modify (&parmse->pre, ctree, tmp);
589 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse, e);
594 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
596 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
598 fold_convert (TREE_TYPE (tmp), null_pointer_node));
599 gfc_add_modify (&parmse->pre, ctree, tmp);
603 ss = gfc_walk_expr (e);
604 if (ss == gfc_ss_terminator)
607 gfc_conv_expr_reference (parmse, e);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts.u.derived->components->as)
613 type = get_scalar_to_descriptor_type (parmse->expr,
615 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
616 gfc_get_dtype (type));
618 parmse->expr = build3_loc (input_location, COND_EXPR,
619 TREE_TYPE (parmse->expr),
620 cond_optional, parmse->expr,
621 fold_convert (TREE_TYPE (parmse->expr),
623 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
627 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
629 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
631 fold_convert (TREE_TYPE (tmp),
633 gfc_add_modify (&parmse->pre, ctree, tmp);
639 gfc_init_block (&block);
643 parmse->use_offset = 1;
644 gfc_conv_expr_descriptor (parmse, e);
646 /* Detect any array references with vector subscripts. */
647 for (ref = e->ref; ref; ref = ref->next)
648 if (ref->type == REF_ARRAY
649 && ref->u.ar.type != AR_ELEMENT
650 && ref->u.ar.type != AR_FULL)
652 for (dim = 0; dim < ref->u.ar.dimen; dim++)
653 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
655 if (dim < ref->u.ar.dimen)
659 /* Array references with vector subscripts and non-variable expressions
660 need be converted to a one-based descriptor. */
661 if (ref || e->expr_type != EXPR_VARIABLE)
663 for (dim = 0; dim < e->rank; ++dim)
664 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
668 if (e->rank != class_ts.u.derived->components->as->rank)
670 gcc_assert (class_ts.u.derived->components->as->type
672 class_array_data_assign (&block, ctree, parmse->expr, false);
676 if (gfc_expr_attr (e).codimension)
677 parmse->expr = fold_build1_loc (input_location,
681 gfc_add_modify (&block, ctree, parmse->expr);
686 tmp = gfc_finish_block (&block);
688 gfc_init_block (&block);
689 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
691 tmp = build3_v (COND_EXPR, cond_optional, tmp,
692 gfc_finish_block (&block));
693 gfc_add_expr_to_block (&parmse->pre, tmp);
696 gfc_add_block_to_block (&parmse->pre, &block);
700 if (class_ts.u.derived->components->ts.type == BT_DERIVED
701 && class_ts.u.derived->components->ts.u.derived
702 ->attr.unlimited_polymorphic)
704 /* Take care about initializing the _len component correctly. */
705 ctree = gfc_class_len_get (var);
706 if (UNLIMITED_POLY (e))
711 len = gfc_copy_expr (e);
712 gfc_add_len_component (len);
713 gfc_init_se (&se, NULL);
714 gfc_conv_expr (&se, len);
716 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
717 cond_optional, se.expr,
718 fold_convert (TREE_TYPE (se.expr),
724 tmp = integer_zero_node;
725 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
728 /* Pass the address of the class object. */
729 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
731 if (optional && optional_alloc_ptr)
732 parmse->expr = build3_loc (input_location, COND_EXPR,
733 TREE_TYPE (parmse->expr),
734 cond_optional, parmse->expr,
735 fold_convert (TREE_TYPE (parmse->expr),
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
745 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
746 gfc_typespec class_ts, bool optional)
748 tree var, ctree, tmp;
753 gfc_init_block (&block);
756 for (ref = e->ref; ref; ref = ref->next)
758 if (ref->type == REF_COMPONENT
759 && ref->u.c.component->ts.type == BT_CLASS)
763 if (class_ref == NULL
764 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
765 tmp = e->symtree->n.sym->backend_decl;
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
771 ref = class_ref->next;
772 class_ref->next = NULL;
773 gfc_init_se (&tmpse, NULL);
774 gfc_conv_expr (&tmpse, e);
775 class_ref->next = ref;
779 var = gfc_typenode_for_spec (&class_ts);
780 var = gfc_create_var (var, "class");
782 ctree = gfc_class_vptr_get (var);
783 gfc_add_modify (&block, ctree,
784 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
786 ctree = gfc_class_data_get (var);
787 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
788 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
790 /* Pass the address of the class object. */
791 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
795 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
798 tmp = gfc_finish_block (&block);
800 gfc_init_block (&block);
801 tmp2 = gfc_class_data_get (var);
802 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
804 tmp2 = gfc_finish_block (&block);
806 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
808 gfc_add_expr_to_block (&parmse->pre, tmp);
811 gfc_add_block_to_block (&parmse->pre, &block);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
818 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
819 gfc_typespec class_ts)
827 /* The intrinsic type needs to be converted to a temporary
829 tmp = gfc_typenode_for_spec (&class_ts);
830 var = gfc_create_var (tmp, "class");
833 ctree = gfc_class_vptr_get (var);
835 vtab = gfc_find_vtab (&e->ts);
837 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
838 gfc_add_modify (&parmse->pre, ctree,
839 fold_convert (TREE_TYPE (ctree), tmp));
841 /* Now set the data field. */
842 ctree = gfc_class_data_get (var);
843 if (parmse->ss && parmse->ss->info->useflags)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse, e);
848 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
849 gfc_add_modify (&parmse->pre, ctree, tmp);
853 ss = gfc_walk_expr (e);
854 if (ss == gfc_ss_terminator)
857 gfc_conv_expr_reference (parmse, e);
858 if (class_ts.u.derived->components->as
859 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
861 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
863 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
864 TREE_TYPE (ctree), tmp);
867 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
868 gfc_add_modify (&parmse->pre, ctree, tmp);
873 parmse->use_offset = 1;
874 gfc_conv_expr_descriptor (parmse, e);
875 if (class_ts.u.derived->components->as->rank != e->rank)
877 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
878 TREE_TYPE (ctree), parmse->expr);
879 gfc_add_modify (&parmse->pre, ctree, tmp);
882 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
886 gcc_assert (class_ts.type == BT_CLASS);
887 if (class_ts.u.derived->components->ts.type == BT_DERIVED
888 && class_ts.u.derived->components->ts.u.derived
889 ->attr.unlimited_polymorphic)
891 ctree = gfc_class_len_get (var);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e->ts.type == BT_CHARACTER)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse->string_length)
899 tmp = parmse->string_length;
900 /* When the string_length is not yet set, then try the backend_decl of
902 else if (e->ts.u.cl->backend_decl)
903 tmp = e->ts.u.cl->backend_decl;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e, 0);
911 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
916 gfc_charlen_int_kind,
918 mpz_set_ui (e->ts.u.cl->length->value.integer,
919 e->value.character.length);
920 gfc_conv_const_charlen (e->ts.u.cl);
921 e->ts.u.cl->resolved = 1;
922 tmp = e->ts.u.cl->backend_decl;
926 gfc_error ("Can't compute the length of the char array at %L.",
932 tmp = integer_zero_node;
934 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
936 else if (class_ts.type == BT_CLASS
937 && class_ts.u.derived->components
938 && class_ts.u.derived->components->ts.u
939 .derived->attr.unlimited_polymorphic)
941 ctree = gfc_class_len_get (var);
942 gfc_add_modify (&parmse->pre, ctree,
943 fold_convert (TREE_TYPE (ctree),
946 /* Pass the address of the class object. */
947 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
963 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
964 bool elemental, bool copyback, bool optional,
965 bool optional_alloc_ptr)
971 tree cond = NULL_TREE;
972 tree slen = NULL_TREE;
976 bool full_array = false;
978 gfc_init_block (&block);
981 for (ref = e->ref; ref; ref = ref->next)
983 if (ref->type == REF_COMPONENT
984 && ref->u.c.component->ts.type == BT_CLASS)
987 if (ref->next == NULL)
991 if ((ref == NULL || class_ref == ref)
992 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
993 && (!class_ts.u.derived->components->as
994 || class_ts.u.derived->components->as->rank != -1))
997 /* Test for FULL_ARRAY. */
998 if (e->rank == 0 && gfc_expr_attr (e).codimension
999 && gfc_expr_attr (e).dimension)
1002 gfc_is_class_array_ref (e, &full_array);
1004 /* The derived type needs to be converted to a temporary
1006 tmp = gfc_typenode_for_spec (&class_ts);
1007 var = gfc_create_var (tmp, "class");
1010 ctree = gfc_class_data_get (var);
1011 if (class_ts.u.derived->components->as
1012 && e->rank != class_ts.u.derived->components->as->rank)
1016 tree type = get_scalar_to_descriptor_type (parmse->expr,
1018 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1019 gfc_get_dtype (type));
1021 tmp = gfc_class_data_get (parmse->expr);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1023 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1025 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1028 class_array_data_assign (&block, ctree, parmse->expr, false);
1032 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1033 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1034 TREE_TYPE (ctree), parmse->expr);
1035 gfc_add_modify (&block, ctree, parmse->expr);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1041 if (!elemental && full_array && copyback)
1043 if (class_ts.u.derived->components->as
1044 && e->rank != class_ts.u.derived->components->as->rank)
1047 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1048 gfc_conv_descriptor_data_get (ctree));
1050 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1053 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1057 ctree = gfc_class_vptr_get (var);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1063 if (gfc_is_class_array_function (e)
1064 && parmse->class_vptr != NULL_TREE)
1065 tmp = parmse->class_vptr;
1066 else if (class_ref == NULL
1067 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1069 tmp = e->symtree->n.sym->backend_decl;
1071 if (TREE_CODE (tmp) == FUNCTION_DECL)
1072 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1074 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1075 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1077 slen = build_zero_cst (size_type_node);
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1084 ref = class_ref->next;
1085 class_ref->next = NULL;
1086 gfc_init_se (&tmpse, NULL);
1087 gfc_conv_expr (&tmpse, e);
1088 class_ref->next = ref;
1090 slen = tmpse.string_length;
1093 gcc_assert (tmp != NULL_TREE);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1097 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1099 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1100 vptr = gfc_class_vptr_get (tmp);
1104 gfc_add_modify (&block, ctree,
1105 fold_convert (TREE_TYPE (ctree), vptr));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental && full_array && copyback)
1110 gfc_add_modify (&parmse->post, vptr,
1111 fold_convert (TREE_TYPE (vptr), ctree));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts.type == BT_CLASS
1115 && class_ts.u.derived->components
1116 && class_ts.u.derived->components->ts.u
1117 .derived->attr.unlimited_polymorphic)
1119 ctree = gfc_class_len_get (var);
1120 if (UNLIMITED_POLY (e))
1121 tmp = gfc_class_len_get (tmp);
1122 else if (e->ts.type == BT_CHARACTER)
1124 gcc_assert (slen != NULL_TREE);
1128 tmp = build_zero_cst (size_type_node);
1129 gfc_add_modify (&parmse->pre, ctree,
1130 fold_convert (TREE_TYPE (ctree), tmp));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental && full_array && copyback
1135 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1136 gfc_add_modify (&parmse->post, tmp,
1137 fold_convert (TREE_TYPE (tmp), ctree));
1144 cond = gfc_conv_expr_present (e->symtree->n.sym);
1145 /* parmse->pre may contain some preparatory instructions for the
1146 temporary array descriptor. Those may only be executed when the
1147 optional argument is set, therefore add parmse->pre's instructions
1148 to block, which is later guarded by an if (optional_arg_given). */
1149 gfc_add_block_to_block (&parmse->pre, &block);
1150 block.head = parmse->pre.head;
1151 parmse->pre.head = NULL_TREE;
1152 tmp = gfc_finish_block (&block);
1154 if (optional_alloc_ptr)
1155 tmp2 = build_empty_stmt (input_location);
1158 gfc_init_block (&block);
1160 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1161 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1162 null_pointer_node));
1163 tmp2 = gfc_finish_block (&block);
1166 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1168 gfc_add_expr_to_block (&parmse->pre, tmp);
1171 gfc_add_block_to_block (&parmse->pre, &block);
1173 /* Pass the address of the class object. */
1174 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1176 if (optional && optional_alloc_ptr)
1177 parmse->expr = build3_loc (input_location, COND_EXPR,
1178 TREE_TYPE (parmse->expr),
1180 fold_convert (TREE_TYPE (parmse->expr),
1181 null_pointer_node));
1185 /* Given a class array declaration and an index, returns the address
1186 of the referenced element. */
1189 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1192 tree data, size, tmp, ctmp, offset, ptr;
1194 data = data_comp != NULL_TREE ? data_comp :
1195 gfc_class_data_get (class_decl);
1196 size = gfc_class_vtab_size_get (class_decl);
1200 tmp = fold_convert (gfc_array_index_type,
1201 gfc_class_len_get (class_decl));
1202 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1203 gfc_array_index_type, size, tmp);
1204 tmp = fold_build2_loc (input_location, GT_EXPR,
1205 logical_type_node, tmp,
1206 build_zero_cst (TREE_TYPE (tmp)));
1207 size = fold_build3_loc (input_location, COND_EXPR,
1208 gfc_array_index_type, tmp, ctmp, size);
1211 offset = fold_build2_loc (input_location, MULT_EXPR,
1212 gfc_array_index_type,
1215 data = gfc_conv_descriptor_data_get (data);
1216 ptr = fold_convert (pvoid_type_node, data);
1217 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1218 return fold_convert (TREE_TYPE (data), ptr);
1222 /* Copies one class expression to another, assuming that if either
1223 'to' or 'from' are arrays they are packed. Should 'from' be
1224 NULL_TREE, the initialization expression for 'to' is used, assuming
1225 that the _vptr is set. */
1228 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1238 vec<tree, va_gc> *args;
1243 bool is_from_desc = false, is_to_class = false;
1246 /* To prevent warnings on uninitialized variables. */
1247 from_len = to_len = NULL_TREE;
1249 if (from != NULL_TREE)
1250 fcn = gfc_class_vtab_copy_get (from);
1252 fcn = gfc_class_vtab_copy_get (to);
1254 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1256 if (from != NULL_TREE)
1258 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1262 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1266 /* Check that from is a class. When the class is part of a coarray,
1267 then from is a common pointer and is to be used as is. */
1268 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1269 ? build_fold_indirect_ref (from) : from;
1271 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1272 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1273 ? gfc_class_data_get (from) : from;
1274 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1278 from_data = gfc_class_vtab_def_init_get (to);
1282 if (from != NULL_TREE && unlimited)
1283 from_len = gfc_class_len_or_zero_get (from);
1285 from_len = build_zero_cst (size_type_node);
1288 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1291 to_data = gfc_class_data_get (to);
1293 to_len = gfc_class_len_get (to);
1296 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1299 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1301 stmtblock_t loopbody;
1305 tree orig_nelems = nelems; /* Needed for bounds check. */
1307 gfc_init_block (&body);
1308 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1309 gfc_array_index_type, nelems,
1310 gfc_index_one_node);
1311 nelems = gfc_evaluate_now (tmp, &body);
1312 index = gfc_create_var (gfc_array_index_type, "S");
1316 from_ref = gfc_get_class_array_ref (index, from, from_data,
1318 vec_safe_push (args, from_ref);
1321 vec_safe_push (args, from_data);
1324 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1327 tmp = gfc_conv_array_data (to);
1328 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1329 to_ref = gfc_build_addr_expr (NULL_TREE,
1330 gfc_build_array_ref (tmp, index, to));
1332 vec_safe_push (args, to_ref);
1334 /* Add bounds check. */
1335 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1338 const char *name = "<<unknown>>";
1342 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1344 from_len = gfc_conv_descriptor_size (from_data, 1);
1345 tmp = fold_build2_loc (input_location, NE_EXPR,
1346 logical_type_node, from_len, orig_nelems);
1347 msg = xasprintf ("Array bound mismatch for dimension %d "
1348 "of array '%s' (%%ld/%%ld)",
1351 gfc_trans_runtime_check (true, false, tmp, &body,
1352 &gfc_current_locus, msg,
1353 fold_convert (long_integer_type_node, orig_nelems),
1354 fold_convert (long_integer_type_node, from_len));
1359 tmp = build_call_vec (fcn_type, fcn, args);
1361 /* Build the body of the loop. */
1362 gfc_init_block (&loopbody);
1363 gfc_add_expr_to_block (&loopbody, tmp);
1365 /* Build the loop and return. */
1366 gfc_init_loopinfo (&loop);
1368 loop.from[0] = gfc_index_zero_node;
1369 loop.loopvar[0] = index;
1370 loop.to[0] = nelems;
1371 gfc_trans_scalarizing_loops (&loop, &loopbody);
1372 gfc_init_block (&ifbody);
1373 gfc_add_block_to_block (&ifbody, &loop.pre);
1374 stdcopy = gfc_finish_block (&ifbody);
1375 /* In initialization mode from_len is a constant zero. */
1376 if (unlimited && !integer_zerop (from_len))
1378 vec_safe_push (args, from_len);
1379 vec_safe_push (args, to_len);
1380 tmp = build_call_vec (fcn_type, fcn, args);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody);
1383 gfc_add_expr_to_block (&loopbody, tmp);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop);
1388 loop.from[0] = gfc_index_zero_node;
1389 loop.loopvar[0] = index;
1390 loop.to[0] = nelems;
1391 gfc_trans_scalarizing_loops (&loop, &loopbody);
1392 gfc_init_block (&ifbody);
1393 gfc_add_block_to_block (&ifbody, &loop.pre);
1394 extcopy = gfc_finish_block (&ifbody);
1396 tmp = fold_build2_loc (input_location, GT_EXPR,
1397 logical_type_node, from_len,
1398 build_zero_cst (TREE_TYPE (from_len)));
1399 tmp = fold_build3_loc (input_location, COND_EXPR,
1400 void_type_node, tmp, extcopy, stdcopy);
1401 gfc_add_expr_to_block (&body, tmp);
1402 tmp = gfc_finish_block (&body);
1406 gfc_add_expr_to_block (&body, stdcopy);
1407 tmp = gfc_finish_block (&body);
1409 gfc_cleanup_loop (&loop);
1413 gcc_assert (!is_from_desc);
1414 vec_safe_push (args, from_data);
1415 vec_safe_push (args, to_data);
1416 stdcopy = build_call_vec (fcn_type, fcn, args);
1418 /* In initialization mode from_len is a constant zero. */
1419 if (unlimited && !integer_zerop (from_len))
1421 vec_safe_push (args, from_len);
1422 vec_safe_push (args, to_len);
1423 extcopy = build_call_vec (fcn_type, fcn, args);
1424 tmp = fold_build2_loc (input_location, GT_EXPR,
1425 logical_type_node, from_len,
1426 build_zero_cst (TREE_TYPE (from_len)));
1427 tmp = fold_build3_loc (input_location, COND_EXPR,
1428 void_type_node, tmp, extcopy, stdcopy);
1434 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1435 if (from == NULL_TREE)
1438 cond = fold_build2_loc (input_location, NE_EXPR,
1440 from_data, null_pointer_node);
1441 tmp = fold_build3_loc (input_location, COND_EXPR,
1442 void_type_node, cond,
1443 tmp, build_empty_stmt (input_location));
1451 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1453 gfc_actual_arglist *actual;
1458 actual = gfc_get_actual_arglist ();
1459 actual->expr = gfc_copy_expr (rhs);
1460 actual->next = gfc_get_actual_arglist ();
1461 actual->next->expr = gfc_copy_expr (lhs);
1462 ppc = gfc_copy_expr (obj);
1463 gfc_add_vptr_component (ppc);
1464 gfc_add_component_ref (ppc, "_copy");
1465 ppc_code = gfc_get_code (EXEC_CALL);
1466 ppc_code->resolved_sym = ppc->symtree->n.sym;
1467 /* Although '_copy' is set to be elemental in class.c, it is
1468 not staying that way. Find out why, sometime.... */
1469 ppc_code->resolved_sym->attr.elemental = 1;
1470 ppc_code->ext.actual = actual;
1471 ppc_code->expr1 = ppc;
1472 /* Since '_copy' is elemental, the scalarizer will take care
1473 of arrays in gfc_trans_call. */
1474 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1475 gfc_free_statements (ppc_code);
1477 if (UNLIMITED_POLY(obj))
1479 /* Check if rhs is non-NULL. */
1481 gfc_init_se (&src, NULL);
1482 gfc_conv_expr (&src, rhs);
1483 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1484 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1485 src.expr, fold_convert (TREE_TYPE (src.expr),
1486 null_pointer_node));
1487 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1488 build_empty_stmt (input_location));
1494 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1495 A MEMCPY is needed to copy the full data from the default initializer
1496 of the dynamic type. */
1499 gfc_trans_class_init_assign (gfc_code *code)
1503 gfc_se dst,src,memsz;
1504 gfc_expr *lhs, *rhs, *sz;
1506 gfc_start_block (&block);
1508 lhs = gfc_copy_expr (code->expr1);
1510 rhs = gfc_copy_expr (code->expr1);
1511 gfc_add_vptr_component (rhs);
1513 /* Make sure that the component backend_decls have been built, which
1514 will not have happened if the derived types concerned have not
1516 gfc_get_derived_type (rhs->ts.u.derived);
1517 gfc_add_def_init_component (rhs);
1518 /* The _def_init is always scalar. */
1521 if (code->expr1->ts.type == BT_CLASS
1522 && CLASS_DATA (code->expr1)->attr.dimension)
1524 gfc_array_spec *tmparr = gfc_get_array_spec ();
1525 *tmparr = *CLASS_DATA (code->expr1)->as;
1526 /* Adding the array ref to the class expression results in correct
1527 indexing to the dynamic type. */
1528 gfc_add_full_array_ref (lhs, tmparr);
1529 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1533 /* Scalar initialization needs the _data component. */
1534 gfc_add_data_component (lhs);
1535 sz = gfc_copy_expr (code->expr1);
1536 gfc_add_vptr_component (sz);
1537 gfc_add_size_component (sz);
1539 gfc_init_se (&dst, NULL);
1540 gfc_init_se (&src, NULL);
1541 gfc_init_se (&memsz, NULL);
1542 gfc_conv_expr (&dst, lhs);
1543 gfc_conv_expr (&src, rhs);
1544 gfc_conv_expr (&memsz, sz);
1545 gfc_add_block_to_block (&block, &src.pre);
1546 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1548 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1550 if (UNLIMITED_POLY(code->expr1))
1552 /* Check if _def_init is non-NULL. */
1553 tree cond = fold_build2_loc (input_location, NE_EXPR,
1554 logical_type_node, src.expr,
1555 fold_convert (TREE_TYPE (src.expr),
1556 null_pointer_node));
1557 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1558 tmp, build_empty_stmt (input_location));
1562 if (code->expr1->symtree->n.sym->attr.optional
1563 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1565 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1566 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1568 build_empty_stmt (input_location));
1571 gfc_add_expr_to_block (&block, tmp);
1573 return gfc_finish_block (&block);
1577 /* End of prototype trans-class.c */
1581 realloc_lhs_warning (bt type, bool array, locus *where)
1583 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1584 gfc_warning (OPT_Wrealloc_lhs,
1585 "Code for reallocating the allocatable array at %L will "
1587 else if (warn_realloc_lhs_all)
1588 gfc_warning (OPT_Wrealloc_lhs_all,
1589 "Code for reallocating the allocatable variable at %L "
1590 "will be added", where);
1594 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1597 /* Copy the scalarization loop variables. */
1600 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1603 dest->loop = src->loop;
1607 /* Initialize a simple expression holder.
1609 Care must be taken when multiple se are created with the same parent.
1610 The child se must be kept in sync. The easiest way is to delay creation
1611 of a child se until after after the previous se has been translated. */
1614 gfc_init_se (gfc_se * se, gfc_se * parent)
1616 memset (se, 0, sizeof (gfc_se));
1617 gfc_init_block (&se->pre);
1618 gfc_init_block (&se->post);
1620 se->parent = parent;
1623 gfc_copy_se_loopvars (se, parent);
1627 /* Advances to the next SS in the chain. Use this rather than setting
1628 se->ss = se->ss->next because all the parents needs to be kept in sync.
1632 gfc_advance_se_ss_chain (gfc_se * se)
1637 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1640 /* Walk down the parent chain. */
1643 /* Simple consistency check. */
1644 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1645 || p->parent->ss->nested_ss == p->ss);
1647 /* If we were in a nested loop, the next scalarized expression can be
1648 on the parent ss' next pointer. Thus we should not take the next
1649 pointer blindly, but rather go up one nest level as long as next
1650 is the end of chain. */
1652 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1662 /* Ensures the result of the expression as either a temporary variable
1663 or a constant so that it can be used repeatedly. */
1666 gfc_make_safe_expr (gfc_se * se)
1670 if (CONSTANT_CLASS_P (se->expr))
1673 /* We need a temporary for this result. */
1674 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1675 gfc_add_modify (&se->pre, var, se->expr);
1680 /* Return an expression which determines if a dummy parameter is present.
1681 Also used for arguments to procedures with multiple entry points. */
1684 gfc_conv_expr_present (gfc_symbol * sym)
1688 gcc_assert (sym->attr.dummy);
1689 decl = gfc_get_symbol_decl (sym);
1691 /* Intrinsic scalars with VALUE attribute which are passed by value
1692 use a hidden argument to denote the present status. */
1693 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1694 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1695 && !sym->attr.dimension)
1697 char name[GFC_MAX_SYMBOL_LEN + 2];
1700 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1702 strcpy (&name[1], sym->name);
1703 tree_name = get_identifier (name);
1705 /* Walk function argument list to find hidden arg. */
1706 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1707 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1708 if (DECL_NAME (cond) == tree_name)
1715 if (TREE_CODE (decl) != PARM_DECL)
1717 /* Array parameters use a temporary descriptor, we want the real
1719 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1720 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1721 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1724 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1725 fold_convert (TREE_TYPE (decl), null_pointer_node));
1727 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1728 as actual argument to denote absent dummies. For array descriptors,
1729 we thus also need to check the array descriptor. For BT_CLASS, it
1730 can also occur for scalars and F2003 due to type->class wrapping and
1731 class->class wrapping. Note further that BT_CLASS always uses an
1732 array descriptor for arrays, also for explicit-shape/assumed-size. */
1734 if (!sym->attr.allocatable
1735 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1736 || (sym->ts.type == BT_CLASS
1737 && !CLASS_DATA (sym)->attr.allocatable
1738 && !CLASS_DATA (sym)->attr.class_pointer))
1739 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1740 || sym->ts.type == BT_CLASS))
1744 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1745 || sym->as->type == AS_ASSUMED_RANK
1746 || sym->attr.codimension))
1747 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1749 tmp = build_fold_indirect_ref_loc (input_location, decl);
1750 if (sym->ts.type == BT_CLASS)
1751 tmp = gfc_class_data_get (tmp);
1752 tmp = gfc_conv_array_data (tmp);
1754 else if (sym->ts.type == BT_CLASS)
1755 tmp = gfc_class_data_get (decl);
1759 if (tmp != NULL_TREE)
1761 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1762 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1763 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1764 logical_type_node, cond, tmp);
1772 /* Converts a missing, dummy argument into a null or zero. */
1775 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1780 present = gfc_conv_expr_present (arg->symtree->n.sym);
1784 /* Create a temporary and convert it to the correct type. */
1785 tmp = gfc_get_int_type (kind);
1786 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1789 /* Test for a NULL value. */
1790 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1791 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1792 tmp = gfc_evaluate_now (tmp, &se->pre);
1793 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1797 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1799 build_zero_cst (TREE_TYPE (se->expr)));
1800 tmp = gfc_evaluate_now (tmp, &se->pre);
1804 if (ts.type == BT_CHARACTER)
1806 tmp = build_int_cst (gfc_charlen_type_node, 0);
1807 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1808 present, se->string_length, tmp);
1809 tmp = gfc_evaluate_now (tmp, &se->pre);
1810 se->string_length = tmp;
1816 /* Get the character length of an expression, looking through gfc_refs
1820 gfc_get_expr_charlen (gfc_expr *e)
1825 gcc_assert (e->expr_type == EXPR_VARIABLE
1826 && e->ts.type == BT_CHARACTER);
1828 length = NULL; /* To silence compiler warning. */
1830 if (is_subref_array (e) && e->ts.u.cl->length)
1833 gfc_init_se (&tmpse, NULL);
1834 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1835 e->ts.u.cl->backend_decl = tmpse.expr;
1839 /* First candidate: if the variable is of type CHARACTER, the
1840 expression's length could be the length of the character
1842 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1843 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1845 /* Look through the reference chain for component references. */
1846 for (r = e->ref; r; r = r->next)
1851 if (r->u.c.component->ts.type == BT_CHARACTER)
1852 length = r->u.c.component->ts.u.cl->backend_decl;
1860 /* We should never got substring references here. These will be
1861 broken down by the scalarizer. */
1867 gcc_assert (length != NULL);
1872 /* Return for an expression the backend decl of the coarray. */
1875 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1881 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1883 /* Not-implemented diagnostic. */
1884 if (expr->symtree->n.sym->ts.type == BT_CLASS
1885 && UNLIMITED_POLY (expr->symtree->n.sym)
1886 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1887 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1888 "%L is not supported", &expr->where);
1890 for (ref = expr->ref; ref; ref = ref->next)
1891 if (ref->type == REF_COMPONENT)
1893 if (ref->u.c.component->ts.type == BT_CLASS
1894 && UNLIMITED_POLY (ref->u.c.component)
1895 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1896 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1897 "component at %L is not supported", &expr->where);
1900 /* Make sure the backend_decl is present before accessing it. */
1901 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1902 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1903 : expr->symtree->n.sym->backend_decl;
1905 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1907 if (expr->ref && expr->ref->type == REF_ARRAY)
1909 caf_decl = gfc_class_data_get (caf_decl);
1910 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1913 for (ref = expr->ref; ref; ref = ref->next)
1915 if (ref->type == REF_COMPONENT
1916 && strcmp (ref->u.c.component->name, "_data") != 0)
1918 caf_decl = gfc_class_data_get (caf_decl);
1919 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1923 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1927 if (expr->symtree->n.sym->attr.codimension)
1930 /* The following code assumes that the coarray is a component reachable via
1931 only scalar components/variables; the Fortran standard guarantees this. */
1933 for (ref = expr->ref; ref; ref = ref->next)
1934 if (ref->type == REF_COMPONENT)
1936 gfc_component *comp = ref->u.c.component;
1938 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1939 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1940 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1941 TREE_TYPE (comp->backend_decl), caf_decl,
1942 comp->backend_decl, NULL_TREE);
1943 if (comp->ts.type == BT_CLASS)
1945 caf_decl = gfc_class_data_get (caf_decl);
1946 if (CLASS_DATA (comp)->attr.codimension)
1952 if (comp->attr.codimension)
1958 gcc_assert (found && caf_decl);
1963 /* Obtain the Coarray token - and optionally also the offset. */
1966 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1967 tree se_expr, gfc_expr *expr)
1971 /* Coarray token. */
1972 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1974 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1975 == GFC_ARRAY_ALLOCATABLE
1976 || expr->symtree->n.sym->attr.select_type_temporary);
1977 *token = gfc_conv_descriptor_token (caf_decl);
1979 else if (DECL_LANG_SPECIFIC (caf_decl)
1980 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1981 *token = GFC_DECL_TOKEN (caf_decl);
1984 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1985 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1986 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1992 /* Offset between the coarray base address and the address wanted. */
1993 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1994 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1995 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1996 *offset = build_int_cst (gfc_array_index_type, 0);
1997 else if (DECL_LANG_SPECIFIC (caf_decl)
1998 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1999 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2000 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2001 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2003 *offset = build_int_cst (gfc_array_index_type, 0);
2005 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2006 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2008 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2009 tmp = gfc_conv_descriptor_data_get (tmp);
2011 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2012 tmp = gfc_conv_descriptor_data_get (se_expr);
2015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2019 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2020 *offset, fold_convert (gfc_array_index_type, tmp));
2022 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2023 && expr->symtree->n.sym->attr.codimension
2024 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2026 gfc_expr *base_expr = gfc_copy_expr (expr);
2027 gfc_ref *ref = base_expr->ref;
2030 // Iterate through the refs until the last one.
2034 if (ref->type == REF_ARRAY
2035 && ref->u.ar.type != AR_FULL)
2037 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2039 for (i = 0; i < ranksum; ++i)
2041 ref->u.ar.start[i] = NULL;
2042 ref->u.ar.end[i] = NULL;
2044 ref->u.ar.type = AR_FULL;
2046 gfc_init_se (&base_se, NULL);
2047 if (gfc_caf_attr (base_expr).dimension)
2049 gfc_conv_expr_descriptor (&base_se, base_expr);
2050 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2054 gfc_conv_expr (&base_se, base_expr);
2058 gfc_free_expr (base_expr);
2059 gfc_add_block_to_block (&se->pre, &base_se.pre);
2060 gfc_add_block_to_block (&se->post, &base_se.post);
2062 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2063 tmp = gfc_conv_descriptor_data_get (caf_decl);
2066 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2070 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2071 fold_convert (gfc_array_index_type, *offset),
2072 fold_convert (gfc_array_index_type, tmp));
2076 /* Convert the coindex of a coarray into an image index; the result is
2077 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2078 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2081 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2084 tree lbound, ubound, extent, tmp, img_idx;
2088 for (ref = e->ref; ref; ref = ref->next)
2089 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2091 gcc_assert (ref != NULL);
2093 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2095 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2099 img_idx = build_zero_cst (gfc_array_index_type);
2100 extent = build_one_cst (gfc_array_index_type);
2101 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2102 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2104 gfc_init_se (&se, NULL);
2105 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2106 gfc_add_block_to_block (block, &se.pre);
2107 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2108 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2109 TREE_TYPE (lbound), se.expr, lbound);
2110 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2112 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2113 TREE_TYPE (tmp), img_idx, tmp);
2114 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2116 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2117 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2118 extent = fold_build2_loc (input_location, MULT_EXPR,
2119 TREE_TYPE (tmp), extent, tmp);
2123 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2125 gfc_init_se (&se, NULL);
2126 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2127 gfc_add_block_to_block (block, &se.pre);
2128 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2129 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2130 TREE_TYPE (lbound), se.expr, lbound);
2131 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2133 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2135 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2137 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2138 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2139 TREE_TYPE (ubound), ubound, lbound);
2140 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2141 tmp, build_one_cst (TREE_TYPE (tmp)));
2142 extent = fold_build2_loc (input_location, MULT_EXPR,
2143 TREE_TYPE (tmp), extent, tmp);
2146 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2147 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2148 return fold_convert (integer_type_node, img_idx);
2152 /* For each character array constructor subexpression without a ts.u.cl->length,
2153 replace it by its first element (if there aren't any elements, the length
2154 should already be set to zero). */
2157 flatten_array_ctors_without_strlen (gfc_expr* e)
2159 gfc_actual_arglist* arg;
2165 switch (e->expr_type)
2169 flatten_array_ctors_without_strlen (e->value.op.op1);
2170 flatten_array_ctors_without_strlen (e->value.op.op2);
2174 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2178 for (arg = e->value.function.actual; arg; arg = arg->next)
2179 flatten_array_ctors_without_strlen (arg->expr);
2184 /* We've found what we're looking for. */
2185 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2190 gcc_assert (e->value.constructor);
2192 c = gfc_constructor_first (e->value.constructor);
2196 flatten_array_ctors_without_strlen (new_expr);
2197 gfc_replace_expr (e, new_expr);
2201 /* Otherwise, fall through to handle constructor elements. */
2203 case EXPR_STRUCTURE:
2204 for (c = gfc_constructor_first (e->value.constructor);
2205 c; c = gfc_constructor_next (c))
2206 flatten_array_ctors_without_strlen (c->expr);
2216 /* Generate code to initialize a string length variable. Returns the
2217 value. For array constructors, cl->length might be NULL and in this case,
2218 the first element of the constructor is needed. expr is the original
2219 expression so we can access it but can be NULL if this is not needed. */
2222 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2226 gfc_init_se (&se, NULL);
2228 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2231 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2232 "flatten" array constructors by taking their first element; all elements
2233 should be the same length or a cl->length should be present. */
2236 gfc_expr* expr_flat;
2239 expr_flat = gfc_copy_expr (expr);
2240 flatten_array_ctors_without_strlen (expr_flat);
2241 gfc_resolve_expr (expr_flat);
2243 gfc_conv_expr (&se, expr_flat);
2244 gfc_add_block_to_block (pblock, &se.pre);
2245 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2247 gfc_free_expr (expr_flat);
2251 /* Convert cl->length. */
2253 gcc_assert (cl->length);
2255 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2256 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2257 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2258 gfc_add_block_to_block (pblock, &se.pre);
2260 if (cl->backend_decl)
2261 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2263 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2268 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2269 const char *name, locus *where)
2279 type = gfc_get_character_type (kind, ref->u.ss.length);
2280 type = build_pointer_type (type);
2282 gfc_init_se (&start, se);
2283 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2284 gfc_add_block_to_block (&se->pre, &start.pre);
2286 if (integer_onep (start.expr))
2287 gfc_conv_string_parameter (se);
2292 /* Avoid multiple evaluation of substring start. */
2293 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2294 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2296 /* Change the start of the string. */
2297 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2300 tmp = build_fold_indirect_ref_loc (input_location,
2302 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2303 se->expr = gfc_build_addr_expr (type, tmp);
2306 /* Length = end + 1 - start. */
2307 gfc_init_se (&end, se);
2308 if (ref->u.ss.end == NULL)
2309 end.expr = se->string_length;
2312 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2313 gfc_add_block_to_block (&se->pre, &end.pre);
2317 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2318 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2320 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2322 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2323 logical_type_node, start.expr,
2326 /* Check lower bound. */
2327 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2329 build_one_cst (TREE_TYPE (start.expr)));
2330 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2331 logical_type_node, nonempty, fault);
2333 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2334 "is less than one", name);
2336 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2337 "is less than one");
2338 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2339 fold_convert (long_integer_type_node,
2343 /* Check upper bound. */
2344 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2345 end.expr, se->string_length);
2346 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2347 logical_type_node, nonempty, fault);
2349 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2350 "exceeds string length (%%ld)", name);
2352 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2353 "exceeds string length (%%ld)");
2354 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2355 fold_convert (long_integer_type_node, end.expr),
2356 fold_convert (long_integer_type_node,
2357 se->string_length));
2361 /* Try to calculate the length from the start and end expressions. */
2363 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2365 HOST_WIDE_INT i_len;
2367 i_len = gfc_mpz_get_hwi (length) + 1;
2371 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2372 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2376 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2377 fold_convert (gfc_charlen_type_node, end.expr),
2378 fold_convert (gfc_charlen_type_node, start.expr));
2379 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2380 build_int_cst (gfc_charlen_type_node, 1), tmp);
2381 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2382 tmp, build_int_cst (gfc_charlen_type_node, 0));
2385 se->string_length = tmp;
2389 /* Convert a derived type component reference. */
2392 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2400 c = ref->u.c.component;
2402 if (c->backend_decl == NULL_TREE
2403 && ref->u.c.sym != NULL)
2404 gfc_get_derived_type (ref->u.c.sym);
2406 field = c->backend_decl;
2407 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2409 context = DECL_FIELD_CONTEXT (field);
2411 /* Components can correspond to fields of different containing
2412 types, as components are created without context, whereas
2413 a concrete use of a component has the type of decl as context.
2414 So, if the type doesn't match, we search the corresponding
2415 FIELD_DECL in the parent type. To not waste too much time
2416 we cache this result in norestrict_decl.
2417 On the other hand, if the context is a UNION or a MAP (a
2418 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2420 if (context != TREE_TYPE (decl)
2421 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2422 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2424 tree f2 = c->norestrict_decl;
2425 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2426 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2427 if (TREE_CODE (f2) == FIELD_DECL
2428 && DECL_NAME (f2) == DECL_NAME (field))
2431 c->norestrict_decl = f2;
2435 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2436 && strcmp ("_data", c->name) == 0)
2438 /* Found a ref to the _data component. Store the associated ref to
2439 the vptr in se->class_vptr. */
2440 se->class_vptr = gfc_class_vptr_get (decl);
2443 se->class_vptr = NULL_TREE;
2445 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2446 decl, field, NULL_TREE);
2450 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2451 strlen () conditional below. */
2452 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2453 && !(c->attr.allocatable && c->ts.deferred)
2454 && !c->attr.pdt_string)
2456 tmp = c->ts.u.cl->backend_decl;
2457 /* Components must always be constant length. */
2458 gcc_assert (tmp && INTEGER_CST_P (tmp));
2459 se->string_length = tmp;
2462 if (gfc_deferred_strlen (c, &field))
2464 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2466 decl, field, NULL_TREE);
2467 se->string_length = tmp;
2470 if (((c->attr.pointer || c->attr.allocatable)
2471 && (!c->attr.dimension && !c->attr.codimension)
2472 && c->ts.type != BT_CHARACTER)
2473 || c->attr.proc_pointer)
2474 se->expr = build_fold_indirect_ref_loc (input_location,
2479 /* This function deals with component references to components of the
2480 parent type for derived type extensions. */
2482 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2490 c = ref->u.c.component;
2492 /* Return if the component is in the parent type. */
2493 for (cmp = dt->components; cmp; cmp = cmp->next)
2494 if (strcmp (c->name, cmp->name) == 0)
2497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2498 parent.type = REF_COMPONENT;
2500 parent.u.c.sym = dt;
2501 parent.u.c.component = dt->components;
2503 if (dt->backend_decl == NULL)
2504 gfc_get_derived_type (dt);
2506 /* Build the reference and call self. */
2507 gfc_conv_component_ref (se, &parent);
2508 parent.u.c.sym = dt->components->ts.u.derived;
2509 parent.u.c.component = c;
2510 conv_parent_component_references (se, &parent);
2515 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2517 tree res = se->expr;
2522 res = fold_build1_loc (input_location, REALPART_EXPR,
2523 TREE_TYPE (TREE_TYPE (res)), res);
2527 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2528 TREE_TYPE (TREE_TYPE (res)), res);
2532 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2537 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2547 /* Return the contents of a variable. Also handles reference/pointer
2548 variables (all Fortran pointer references are implicit). */
2551 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2556 tree parent_decl = NULL_TREE;
2559 bool alternate_entry;
2562 bool first_time = true;
2564 sym = expr->symtree->n.sym;
2565 is_classarray = IS_CLASS_ARRAY (sym);
2569 gfc_ss_info *ss_info = ss->info;
2571 /* Check that something hasn't gone horribly wrong. */
2572 gcc_assert (ss != gfc_ss_terminator);
2573 gcc_assert (ss_info->expr == expr);
2575 /* A scalarized term. We already know the descriptor. */
2576 se->expr = ss_info->data.array.descriptor;
2577 se->string_length = ss_info->string_length;
2578 ref = ss_info->data.array.ref;
2580 gcc_assert (ref->type == REF_ARRAY
2581 && ref->u.ar.type != AR_ELEMENT);
2583 gfc_conv_tmp_array_ref (se);
2587 tree se_expr = NULL_TREE;
2589 se->expr = gfc_get_symbol_decl (sym);
2591 /* Deal with references to a parent results or entries by storing
2592 the current_function_decl and moving to the parent_decl. */
2593 return_value = sym->attr.function && sym->result == sym;
2594 alternate_entry = sym->attr.function && sym->attr.entry
2595 && sym->result == sym;
2596 entry_master = sym->attr.result
2597 && sym->ns->proc_name->attr.entry_master
2598 && !gfc_return_by_reference (sym->ns->proc_name);
2599 if (current_function_decl)
2600 parent_decl = DECL_CONTEXT (current_function_decl);
2602 if ((se->expr == parent_decl && return_value)
2603 || (sym->ns && sym->ns->proc_name
2605 && sym->ns->proc_name->backend_decl == parent_decl
2606 && (alternate_entry || entry_master)))
2611 /* Special case for assigning the return value of a function.
2612 Self recursive functions must have an explicit return value. */
2613 if (return_value && (se->expr == current_function_decl || parent_flag))
2614 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2616 /* Similarly for alternate entry points. */
2617 else if (alternate_entry
2618 && (sym->ns->proc_name->backend_decl == current_function_decl
2621 gfc_entry_list *el = NULL;
2623 for (el = sym->ns->entries; el; el = el->next)
2626 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2631 else if (entry_master
2632 && (sym->ns->proc_name->backend_decl == current_function_decl
2634 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2639 /* Procedure actual arguments. Look out for temporary variables
2640 with the same attributes as function values. */
2641 else if (!sym->attr.temporary
2642 && sym->attr.flavor == FL_PROCEDURE
2643 && se->expr != current_function_decl)
2645 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2647 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2648 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2654 /* Dereference the expression, where needed. Since characters
2655 are entirely different from other types, they are treated
2657 if (sym->ts.type == BT_CHARACTER)
2659 /* Dereference character pointer dummy arguments
2661 if ((sym->attr.pointer || sym->attr.allocatable)
2663 || sym->attr.function
2664 || sym->attr.result))
2665 se->expr = build_fold_indirect_ref_loc (input_location,
2669 else if (!sym->attr.value)
2671 /* Dereference temporaries for class array dummy arguments. */
2672 if (sym->attr.dummy && is_classarray
2673 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2675 if (!se->descriptor_only)
2676 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2678 se->expr = build_fold_indirect_ref_loc (input_location,
2682 /* Dereference non-character scalar dummy arguments. */
2683 if (sym->attr.dummy && !sym->attr.dimension
2684 && !(sym->attr.codimension && sym->attr.allocatable)
2685 && (sym->ts.type != BT_CLASS
2686 || (!CLASS_DATA (sym)->attr.dimension
2687 && !(CLASS_DATA (sym)->attr.codimension
2688 && CLASS_DATA (sym)->attr.allocatable))))
2689 se->expr = build_fold_indirect_ref_loc (input_location,
2692 /* Dereference scalar hidden result. */
2693 if (flag_f2c && sym->ts.type == BT_COMPLEX
2694 && (sym->attr.function || sym->attr.result)
2695 && !sym->attr.dimension && !sym->attr.pointer
2696 && !sym->attr.always_explicit)
2697 se->expr = build_fold_indirect_ref_loc (input_location,
2700 /* Dereference non-character, non-class pointer variables.
2701 These must be dummies, results, or scalars. */
2703 && (sym->attr.pointer || sym->attr.allocatable
2704 || gfc_is_associate_pointer (sym)
2705 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2707 || sym->attr.function
2709 || (!sym->attr.dimension
2710 && (!sym->attr.codimension || !sym->attr.allocatable))))
2711 se->expr = build_fold_indirect_ref_loc (input_location,
2713 /* Now treat the class array pointer variables accordingly. */
2714 else if (sym->ts.type == BT_CLASS
2716 && (CLASS_DATA (sym)->attr.dimension
2717 || CLASS_DATA (sym)->attr.codimension)
2718 && ((CLASS_DATA (sym)->as
2719 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2720 || CLASS_DATA (sym)->attr.allocatable
2721 || CLASS_DATA (sym)->attr.class_pointer))
2722 se->expr = build_fold_indirect_ref_loc (input_location,
2724 /* And the case where a non-dummy, non-result, non-function,
2725 non-allotable and non-pointer classarray is present. This case was
2726 previously covered by the first if, but with introducing the
2727 condition !is_classarray there, that case has to be covered
2729 else if (sym->ts.type == BT_CLASS
2731 && !sym->attr.function
2732 && !sym->attr.result
2733 && (CLASS_DATA (sym)->attr.dimension
2734 || CLASS_DATA (sym)->attr.codimension)
2736 || !CLASS_DATA (sym)->attr.allocatable)
2737 && !CLASS_DATA (sym)->attr.class_pointer)
2738 se->expr = build_fold_indirect_ref_loc (input_location,
2745 /* For character variables, also get the length. */
2746 if (sym->ts.type == BT_CHARACTER)
2748 /* If the character length of an entry isn't set, get the length from
2749 the master function instead. */
2750 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2751 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2753 se->string_length = sym->ts.u.cl->backend_decl;
2754 gcc_assert (se->string_length);
2757 gfc_typespec *ts = &sym->ts;
2763 /* Return the descriptor if that's what we want and this is an array
2764 section reference. */
2765 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2767 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2768 /* Return the descriptor for array pointers and allocations. */
2769 if (se->want_pointer
2770 && ref->next == NULL && (se->descriptor_only))
2773 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2774 /* Return a pointer to an element. */
2778 ts = &ref->u.c.component->ts;
2779 if (first_time && is_classarray && sym->attr.dummy
2780 && se->descriptor_only
2781 && !CLASS_DATA (sym)->attr.allocatable
2782 && !CLASS_DATA (sym)->attr.class_pointer
2783 && CLASS_DATA (sym)->as
2784 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2785 && strcmp ("_data", ref->u.c.component->name) == 0)
2786 /* Skip the first ref of a _data component, because for class
2787 arrays that one is already done by introducing a temporary
2788 array descriptor. */
2791 if (ref->u.c.sym->attr.extension)
2792 conv_parent_component_references (se, ref);
2794 gfc_conv_component_ref (se, ref);
2795 if (!ref->next && ref->u.c.sym->attr.codimension
2796 && se->want_pointer && se->descriptor_only)
2802 gfc_conv_substring (se, ref, expr->ts.kind,
2803 expr->symtree->name, &expr->where);
2807 conv_inquiry (se, ref, expr, ts);
2817 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2819 if (se->want_pointer)
2821 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2822 gfc_conv_string_parameter (se);
2824 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2829 /* Unary ops are easy... Or they would be if ! was a valid op. */
2832 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2837 gcc_assert (expr->ts.type != BT_CHARACTER);
2838 /* Initialize the operand. */
2839 gfc_init_se (&operand, se);
2840 gfc_conv_expr_val (&operand, expr->value.op.op1);
2841 gfc_add_block_to_block (&se->pre, &operand.pre);
2843 type = gfc_typenode_for_spec (&expr->ts);
2845 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2846 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2847 All other unary operators have an equivalent GIMPLE unary operator. */
2848 if (code == TRUTH_NOT_EXPR)
2849 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2850 build_int_cst (type, 0));
2852 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2856 /* Expand power operator to optimal multiplications when a value is raised
2857 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2858 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2859 Programming", 3rd Edition, 1998. */
2861 /* This code is mostly duplicated from expand_powi in the backend.
2862 We establish the "optimal power tree" lookup table with the defined size.
2863 The items in the table are the exponents used to calculate the index
2864 exponents. Any integer n less than the value can get an "addition chain",
2865 with the first node being one. */
2866 #define POWI_TABLE_SIZE 256
2868 /* The table is from builtins.c. */
2869 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2871 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2872 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2873 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2874 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2875 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2876 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2877 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2878 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2879 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2880 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2881 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2882 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2883 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2884 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2885 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2886 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2887 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2888 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2889 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2890 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2891 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2892 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2893 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2894 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2895 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2896 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2897 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2898 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2899 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2900 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2901 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2902 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2905 /* If n is larger than lookup table's max index, we use the "window
2907 #define POWI_WINDOW_SIZE 3
2909 /* Recursive function to expand the power operator. The temporary
2910 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2912 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2919 if (n < POWI_TABLE_SIZE)
2924 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2925 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2929 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2930 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2931 op1 = gfc_conv_powi (se, digit, tmpvar);
2935 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2939 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2940 tmp = gfc_evaluate_now (tmp, &se->pre);
2942 if (n < POWI_TABLE_SIZE)
2949 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2950 return 1. Else return 0 and a call to runtime library functions
2951 will have to be built. */
2953 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2958 tree vartmp[POWI_TABLE_SIZE];
2960 unsigned HOST_WIDE_INT n;
2962 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2964 /* If exponent is too large, we won't expand it anyway, so don't bother
2965 with large integer values. */
2966 if (!wi::fits_shwi_p (wrhs))
2969 m = wrhs.to_shwi ();
2970 /* Use the wide_int's routine to reliably get the absolute value on all
2971 platforms. Then convert it to a HOST_WIDE_INT like above. */
2972 n = wi::abs (wrhs).to_shwi ();
2974 type = TREE_TYPE (lhs);
2975 sgn = tree_int_cst_sgn (rhs);
2977 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2978 || optimize_size) && (m > 2 || m < -1))
2984 se->expr = gfc_build_const (type, integer_one_node);
2988 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2989 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2991 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2992 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2993 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2994 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2997 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3000 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3001 logical_type_node, tmp, cond);
3002 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3003 tmp, build_int_cst (type, 1),
3004 build_int_cst (type, 0));
3008 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3009 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3010 build_int_cst (type, -1),
3011 build_int_cst (type, 0));
3012 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3013 cond, build_int_cst (type, 1), tmp);
3017 memset (vartmp, 0, sizeof (vartmp));
3021 tmp = gfc_build_const (type, integer_one_node);
3022 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3026 se->expr = gfc_conv_powi (se, n, vartmp);
3032 /* Power op (**). Constant integer exponent has special handling. */
3035 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3037 tree gfc_int4_type_node;
3040 int res_ikind_1, res_ikind_2;
3045 gfc_init_se (&lse, se);
3046 gfc_conv_expr_val (&lse, expr->value.op.op1);
3047 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3048 gfc_add_block_to_block (&se->pre, &lse.pre);
3050 gfc_init_se (&rse, se);
3051 gfc_conv_expr_val (&rse, expr->value.op.op2);
3052 gfc_add_block_to_block (&se->pre, &rse.pre);
3054 if (expr->value.op.op2->ts.type == BT_INTEGER
3055 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3056 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3059 if (INTEGER_CST_P (lse.expr)
3060 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3062 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3064 int kind, ikind, bit_size;
3066 v = wlhs.to_shwi ();
3069 kind = expr->value.op.op1->ts.kind;
3070 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3071 bit_size = gfc_integer_kinds[ikind].bit_size;
3075 /* 1**something is always 1. */
3076 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3081 /* (-1)**n is 1 - ((n & 1) << 1) */
3085 type = TREE_TYPE (lse.expr);
3086 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3087 rse.expr, build_int_cst (type, 1));
3088 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3089 tmp, build_int_cst (type, 1));
3090 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3091 build_int_cst (type, 1), tmp);
3095 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3097 /* Here v is +/- 2**e. The further simplification uses
3098 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3099 1<<(4*n), etc., but we have to make sure to return zero
3100 if the number of bits is too large. */
3110 type = TREE_TYPE (lse.expr);
3115 shift = fold_build2_loc (input_location, PLUS_EXPR,
3116 TREE_TYPE (rse.expr),
3117 rse.expr, rse.expr);
3120 /* use popcount for fast log2(w) */
3121 int e = wi::popcount (w-1);
3122 shift = fold_build2_loc (input_location, MULT_EXPR,
3123 TREE_TYPE (rse.expr),
3124 build_int_cst (TREE_TYPE (rse.expr), e),
3128 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3129 build_int_cst (type, 1), shift);
3130 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3131 rse.expr, build_int_cst (type, 0));
3132 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3133 build_int_cst (type, 0));
3134 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3135 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3136 rse.expr, num_bits);
3137 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3138 build_int_cst (type, 0), cond);
3145 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3147 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3148 rse.expr, build_int_cst (type, 1));
3149 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3150 tmp2, build_int_cst (type, 1));
3151 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3152 build_int_cst (type, 1), tmp2);
3153 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3160 gfc_int4_type_node = gfc_get_int_type (4);
3162 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3163 library routine. But in the end, we have to convert the result back
3164 if this case applies -- with res_ikind_K, we keep track whether operand K
3165 falls into this case. */
3169 kind = expr->value.op.op1->ts.kind;
3170 switch (expr->value.op.op2->ts.type)
3173 ikind = expr->value.op.op2->ts.kind;
3178 rse.expr = convert (gfc_int4_type_node, rse.expr);
3179 res_ikind_2 = ikind;
3201 if (expr->value.op.op1->ts.type == BT_INTEGER)
3203 lse.expr = convert (gfc_int4_type_node, lse.expr);
3230 switch (expr->value.op.op1->ts.type)
3233 if (kind == 3) /* Case 16 was not handled properly above. */
3235 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3239 /* Use builtins for real ** int4. */
3245 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3249 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3253 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3257 /* Use the __builtin_powil() only if real(kind=16) is
3258 actually the C long double type. */
3259 if (!gfc_real16_is_float128)
3260 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3268 /* If we don't have a good builtin for this, go for the
3269 library function. */
3271 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3275 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3284 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3288 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3296 se->expr = build_call_expr_loc (input_location,
3297 fndecl, 2, lse.expr, rse.expr);
3299 /* Convert the result back if it is of wrong integer kind. */
3300 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3302 /* We want the maximum of both operand kinds as result. */
3303 if (res_ikind_1 < res_ikind_2)
3304 res_ikind_1 = res_ikind_2;
3305 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3310 /* Generate code to allocate a string temporary. */
3313 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3318 if (gfc_can_put_var_on_stack (len))
3320 /* Create a temporary variable to hold the result. */
3321 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3322 TREE_TYPE (len), len,
3323 build_int_cst (TREE_TYPE (len), 1));
3324 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3326 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3327 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3329 tmp = build_array_type (TREE_TYPE (type), tmp);
3331 var = gfc_create_var (tmp, "str");
3332 var = gfc_build_addr_expr (type, var);
3336 /* Allocate a temporary to hold the result. */
3337 var = gfc_create_var (type, "pstr");
3338 gcc_assert (POINTER_TYPE_P (type));
3339 tmp = TREE_TYPE (type);
3340 if (TREE_CODE (tmp) == ARRAY_TYPE)
3341 tmp = TREE_TYPE (tmp);
3342 tmp = TYPE_SIZE_UNIT (tmp);
3343 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3344 fold_convert (size_type_node, len),
3345 fold_convert (size_type_node, tmp));
3346 tmp = gfc_call_malloc (&se->pre, type, tmp);
3347 gfc_add_modify (&se->pre, var, tmp);
3349 /* Free the temporary afterwards. */
3350 tmp = gfc_call_free (var);
3351 gfc_add_expr_to_block (&se->post, tmp);
3358 /* Handle a string concatenation operation. A temporary will be allocated to
3362 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3365 tree len, type, var, tmp, fndecl;
3367 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3368 && expr->value.op.op2->ts.type == BT_CHARACTER);
3369 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3371 gfc_init_se (&lse, se);
3372 gfc_conv_expr (&lse, expr->value.op.op1);
3373 gfc_conv_string_parameter (&lse);
3374 gfc_init_se (&rse, se);
3375 gfc_conv_expr (&rse, expr->value.op.op2);
3376 gfc_conv_string_parameter (&rse);
3378 gfc_add_block_to_block (&se->pre, &lse.pre);
3379 gfc_add_block_to_block (&se->pre, &rse.pre);
3381 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3382 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3383 if (len == NULL_TREE)
3385 len = fold_build2_loc (input_location, PLUS_EXPR,
3386 gfc_charlen_type_node,
3387 fold_convert (gfc_charlen_type_node,
3389 fold_convert (gfc_charlen_type_node,
3390 rse.string_length));
3393 type = build_pointer_type (type);
3395 var = gfc_conv_string_tmp (se, type, len);
3397 /* Do the actual concatenation. */
3398 if (expr->ts.kind == 1)
3399 fndecl = gfor_fndecl_concat_string;
3400 else if (expr->ts.kind == 4)
3401 fndecl = gfor_fndecl_concat_string_char4;
3405 tmp = build_call_expr_loc (input_location,
3406 fndecl, 6, len, var, lse.string_length, lse.expr,
3407 rse.string_length, rse.expr);
3408 gfc_add_expr_to_block (&se->pre, tmp);
3410 /* Add the cleanup for the operands. */
3411 gfc_add_block_to_block (&se->pre, &rse.post);
3412 gfc_add_block_to_block (&se->pre, &lse.post);
3415 se->string_length = len;
3418 /* Translates an op expression. Common (binary) cases are handled by this
3419 function, others are passed on. Recursion is used in either case.
3420 We use the fact that (op1.ts == op2.ts) (except for the power
3422 Operators need no special handling for scalarized expressions as long as
3423 they call gfc_conv_simple_val to get their operands.
3424 Character strings get special handling. */
3427 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3429 enum tree_code code;
3438 switch (expr->value.op.op)
3440 case INTRINSIC_PARENTHESES:
3441 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3442 && flag_protect_parens)
3444 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3445 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3450 case INTRINSIC_UPLUS:
3451 gfc_conv_expr (se, expr->value.op.op1);
3454 case INTRINSIC_UMINUS:
3455 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3459 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3462 case INTRINSIC_PLUS:
3466 case INTRINSIC_MINUS:
3470 case INTRINSIC_TIMES:
3474 case INTRINSIC_DIVIDE:
3475 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3476 an integer, we must round towards zero, so we use a
3478 if (expr->ts.type == BT_INTEGER)
3479 code = TRUNC_DIV_EXPR;
3484 case INTRINSIC_POWER:
3485 gfc_conv_power_op (se, expr);
3488 case INTRINSIC_CONCAT:
3489 gfc_conv_concat_op (se, expr);
3493 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3498 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3502 /* EQV and NEQV only work on logicals, but since we represent them
3503 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3505 case INTRINSIC_EQ_OS:
3513 case INTRINSIC_NE_OS:
3514 case INTRINSIC_NEQV:
3521 case INTRINSIC_GT_OS:
3528 case INTRINSIC_GE_OS:
3535 case INTRINSIC_LT_OS:
3542 case INTRINSIC_LE_OS:
3548 case INTRINSIC_USER:
3549 case INTRINSIC_ASSIGN:
3550 /* These should be converted into function calls by the frontend. */
3554 fatal_error (input_location, "Unknown intrinsic op");
3558 /* The only exception to this is **, which is handled separately anyway. */
3559 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3561 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3565 gfc_init_se (&lse, se);
3566 gfc_conv_expr (&lse, expr->value.op.op1);
3567 gfc_add_block_to_block (&se->pre, &lse.pre);
3570 gfc_init_se (&rse, se);
3571 gfc_conv_expr (&rse, expr->value.op.op2);
3572 gfc_add_block_to_block (&se->pre, &rse.pre);
3576 gfc_conv_string_parameter (&lse);
3577 gfc_conv_string_parameter (&rse);
3579 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3580 rse.string_length, rse.expr,
3581 expr->value.op.op1->ts.kind,
3583 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3584 gfc_add_block_to_block (&lse.post, &rse.post);
3587 type = gfc_typenode_for_spec (&expr->ts);
3591 /* The result of logical ops is always logical_type_node. */
3592 tmp = fold_build2_loc (input_location, code, logical_type_node,
3593 lse.expr, rse.expr);
3594 se->expr = convert (type, tmp);
3597 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3599 /* Add the post blocks. */
3600 gfc_add_block_to_block (&se->post, &rse.post);
3601 gfc_add_block_to_block (&se->post, &lse.post);
3604 /* If a string's length is one, we convert it to a single character. */
3607 gfc_string_to_single_character (tree len, tree str, int kind)
3611 || !tree_fits_uhwi_p (len)
3612 || !POINTER_TYPE_P (TREE_TYPE (str)))
3615 if (TREE_INT_CST_LOW (len) == 1)
3617 str = fold_convert (gfc_get_pchar_type (kind), str);
3618 return build_fold_indirect_ref_loc (input_location, str);
3622 && TREE_CODE (str) == ADDR_EXPR
3623 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3624 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3625 && array_ref_low_bound (TREE_OPERAND (str, 0))
3626 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3627 && TREE_INT_CST_LOW (len) > 1
3628 && TREE_INT_CST_LOW (len)
3629 == (unsigned HOST_WIDE_INT)
3630 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3632 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3633 ret = build_fold_indirect_ref_loc (input_location, ret);
3634 if (TREE_CODE (ret) == INTEGER_CST)
3636 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3637 int i, length = TREE_STRING_LENGTH (string_cst);
3638 const char *ptr = TREE_STRING_POINTER (string_cst);
3640 for (i = 1; i < length; i++)
3653 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3656 if (sym->backend_decl)
3658 /* This becomes the nominal_type in
3659 function.c:assign_parm_find_data_types. */
3660 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3661 /* This becomes the passed_type in
3662 function.c:assign_parm_find_data_types. C promotes char to
3663 integer for argument passing. */
3664 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3666 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3671 /* If we have a constant character expression, make it into an
3673 if ((*expr)->expr_type == EXPR_CONSTANT)
3678 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3679 (int)(*expr)->value.character.string[0]);
3680 if ((*expr)->ts.kind != gfc_c_int_kind)
3682 /* The expr needs to be compatible with a C int. If the
3683 conversion fails, then the 2 causes an ICE. */
3684 ts.type = BT_INTEGER;
3685 ts.kind = gfc_c_int_kind;
3686 gfc_convert_type (*expr, &ts, 2);
3689 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3691 if ((*expr)->ref == NULL)
3693 se->expr = gfc_string_to_single_character
3694 (build_int_cst (integer_type_node, 1),
3695 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3697 ((*expr)->symtree->n.sym)),
3702 gfc_conv_variable (se, *expr);
3703 se->expr = gfc_string_to_single_character
3704 (build_int_cst (integer_type_node, 1),
3705 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3713 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3714 if STR is a string literal, otherwise return -1. */
3717 gfc_optimize_len_trim (tree len, tree str, int kind)
3720 && TREE_CODE (str) == ADDR_EXPR
3721 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3722 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3723 && array_ref_low_bound (TREE_OPERAND (str, 0))
3724 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3725 && tree_fits_uhwi_p (len)
3726 && tree_to_uhwi (len) >= 1
3727 && tree_to_uhwi (len)
3728 == (unsigned HOST_WIDE_INT)
3729 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3731 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3732 folded = build_fold_indirect_ref_loc (input_location, folded);
3733 if (TREE_CODE (folded) == INTEGER_CST)
3735 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3736 int length = TREE_STRING_LENGTH (string_cst);
3737 const char *ptr = TREE_STRING_POINTER (string_cst);
3739 for (; length > 0; length--)
3740 if (ptr[length - 1] != ' ')
3749 /* Helper to build a call to memcmp. */
3752 build_memcmp_call (tree s1, tree s2, tree n)
3756 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3757 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3759 s1 = fold_convert (pvoid_type_node, s1);
3761 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3762 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3764 s2 = fold_convert (pvoid_type_node, s2);
3766 n = fold_convert (size_type_node, n);
3768 tmp = build_call_expr_loc (input_location,
3769 builtin_decl_explicit (BUILT_IN_MEMCMP),
3772 return fold_convert (integer_type_node, tmp);
3775 /* Compare two strings. If they are all single characters, the result is the
3776 subtraction of them. Otherwise, we build a library call. */
3779 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3780 enum tree_code code)
3786 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3787 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3789 sc1 = gfc_string_to_single_character (len1, str1, kind);
3790 sc2 = gfc_string_to_single_character (len2, str2, kind);
3792 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3794 /* Deal with single character specially. */
3795 sc1 = fold_convert (integer_type_node, sc1);
3796 sc2 = fold_convert (integer_type_node, sc2);
3797 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3801 if ((code == EQ_EXPR || code == NE_EXPR)
3803 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3805 /* If one string is a string literal with LEN_TRIM longer
3806 than the length of the second string, the strings
3808 int len = gfc_optimize_len_trim (len1, str1, kind);
3809 if (len > 0 && compare_tree_int (len2, len) < 0)
3810 return integer_one_node;
3811 len = gfc_optimize_len_trim (len2, str2, kind);
3812 if (len > 0 && compare_tree_int (len1, len) < 0)
3813 return integer_one_node;
3816 /* We can compare via memcpy if the strings are known to be equal
3817 in length and they are
3819 - kind=4 and the comparison is for (in)equality. */
3821 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3822 && tree_int_cst_equal (len1, len2)
3823 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3828 chartype = gfc_get_char_type (kind);
3829 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3830 fold_convert (TREE_TYPE(len1),
3831 TYPE_SIZE_UNIT(chartype)),
3833 return build_memcmp_call (str1, str2, tmp);
3836 /* Build a call for the comparison. */
3838 fndecl = gfor_fndecl_compare_string;
3840 fndecl = gfor_fndecl_compare_string_char4;
3844 return build_call_expr_loc (input_location, fndecl, 4,
3845 len1, str1, len2, str2);
3849 /* Return the backend_decl for a procedure pointer component. */
3852 get_proc_ptr_comp (gfc_expr *e)
3858 gfc_init_se (&comp_se, NULL);
3859 e2 = gfc_copy_expr (e);
3860 /* We have to restore the expr type later so that gfc_free_expr frees
3861 the exact same thing that was allocated.
3862 TODO: This is ugly. */
3863 old_type = e2->expr_type;
3864 e2->expr_type = EXPR_VARIABLE;
3865 gfc_conv_expr (&comp_se, e2);
3866 e2->expr_type = old_type;
3868 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3872 /* Convert a typebound function reference from a class object. */
3874 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3879 if (!VAR_P (base_object))
3881 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3882 gfc_add_modify (&se->pre, var, base_object);
3884 se->expr = gfc_class_vptr_get (base_object);
3885 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3887 while (ref && ref->next)
3889 gcc_assert (ref && ref->type == REF_COMPONENT);
3890 if (ref->u.c.sym->attr.extension)
3891 conv_parent_component_references (se, ref);
3892 gfc_conv_component_ref (se, ref);
3893 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3898 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3902 if (gfc_is_proc_ptr_comp (expr))
3903 tmp = get_proc_ptr_comp (expr);
3904 else if (sym->attr.dummy)
3906 tmp = gfc_get_symbol_decl (sym);
3907 if (sym->attr.proc_pointer)
3908 tmp = build_fold_indirect_ref_loc (input_location,
3910 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3911 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3915 if (!sym->backend_decl)
3916 sym->backend_decl = gfc_get_extern_function_decl (sym);
3918 TREE_USED (sym->backend_decl) = 1;
3920 tmp = sym->backend_decl;
3922 if (sym->attr.cray_pointee)
3924 /* TODO - make the cray pointee a pointer to a procedure,
3925 assign the pointer to it and use it for the call. This
3927 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3928 gfc_get_symbol_decl (sym->cp_pointer));
3929 tmp = gfc_evaluate_now (tmp, &se->pre);
3932 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3934 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3935 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3942 /* Initialize MAPPING. */
3945 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3947 mapping->syms = NULL;
3948 mapping->charlens = NULL;
3952 /* Free all memory held by MAPPING (but not MAPPING itself). */
3955 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3957 gfc_interface_sym_mapping *sym;
3958 gfc_interface_sym_mapping *nextsym;
3960 gfc_charlen *nextcl;
3962 for (sym = mapping->syms; sym; sym = nextsym)
3964 nextsym = sym->next;
3965 sym->new_sym->n.sym->formal = NULL;
3966 gfc_free_symbol (sym->new_sym->n.sym);
3967 gfc_free_expr (sym->expr);
3968 free (sym->new_sym);
3971 for (cl = mapping->charlens; cl; cl = nextcl)
3974 gfc_free_expr (cl->length);
3980 /* Return a copy of gfc_charlen CL. Add the returned structure to
3981 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3983 static gfc_charlen *
3984 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3987 gfc_charlen *new_charlen;
3989 new_charlen = gfc_get_charlen ();
3990 new_charlen->next = mapping->charlens;
3991 new_charlen->length = gfc_copy_expr (cl->length);
3993 mapping->charlens = new_charlen;
3998 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3999 array variable that can be used as the actual argument for dummy
4000 argument SYM. Add any initialization code to BLOCK. PACKED is as
4001 for gfc_get_nodesc_array_type and DATA points to the first element
4002 in the passed array. */
4005 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4006 gfc_packed packed, tree data)
4011 type = gfc_typenode_for_spec (&sym->ts);
4012 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4013 !sym->attr.target && !sym->attr.pointer
4014 && !sym->attr.proc_pointer);
4016 var = gfc_create_var (type, "ifm");
4017 gfc_add_modify (block, var, fold_convert (type, data));
4023 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4024 and offset of descriptorless array type TYPE given that it has the same
4025 size as DESC. Add any set-up code to BLOCK. */
4028 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4035 offset = gfc_index_zero_node;
4036 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4038 dim = gfc_rank_cst[n];
4039 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4040 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4042 GFC_TYPE_ARRAY_LBOUND (type, n)
4043 = gfc_conv_descriptor_lbound_get (desc, dim);
4044 GFC_TYPE_ARRAY_UBOUND (type, n)
4045 = gfc_conv_descriptor_ubound_get (desc, dim);
4047 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4049 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4050 gfc_array_index_type,
4051 gfc_conv_descriptor_ubound_get (desc, dim),
4052 gfc_conv_descriptor_lbound_get (desc, dim));
4053 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4054 gfc_array_index_type,
4055 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4056 tmp = gfc_evaluate_now (tmp, block);
4057 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4059 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4060 GFC_TYPE_ARRAY_LBOUND (type, n),
4061 GFC_TYPE_ARRAY_STRIDE (type, n));
4062 offset = fold_build2_loc (input_location, MINUS_EXPR,
4063 gfc_array_index_type, offset, tmp);
4065 offset = gfc_evaluate_now (offset, block);
4066 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4070 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4071 in SE. The caller may still use se->expr and se->string_length after
4072 calling this function. */
4075 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4076 gfc_symbol * sym, gfc_se * se,
4079 gfc_interface_sym_mapping *sm;
4083 gfc_symbol *new_sym;
4085 gfc_symtree *new_symtree;
4087 /* Create a new symbol to represent the actual argument. */
4088 new_sym = gfc_new_symbol (sym->name, NULL);
4089 new_sym->ts = sym->ts;
4090 new_sym->as = gfc_copy_array_spec (sym->as);
4091 new_sym->attr.referenced = 1;
4092 new_sym->attr.dimension = sym->attr.dimension;
4093 new_sym->attr.contiguous = sym->attr.contiguous;
4094 new_sym->attr.codimension = sym->attr.codimension;
4095 new_sym->attr.pointer = sym->attr.pointer;
4096 new_sym->attr.allocatable = sym->attr.allocatable;
4097 new_sym->attr.flavor = sym->attr.flavor;
4098 new_sym->attr.function = sym->attr.function;
4100 /* Ensure that the interface is available and that
4101 descriptors are passed for array actual arguments. */
4102 if (sym->attr.flavor == FL_PROCEDURE)
4104 new_sym->formal = expr->symtree->n.sym->formal;
4105 new_sym->attr.always_explicit
4106 = expr->symtree->n.sym->attr.always_explicit;
4109 /* Create a fake symtree for it. */
4111 new_symtree = gfc_new_symtree (&root, sym->name);
4112 new_symtree->n.sym = new_sym;
4113 gcc_assert (new_symtree == root);
4115 /* Create a dummy->actual mapping. */
4116 sm = XCNEW (gfc_interface_sym_mapping);
4117 sm->next = mapping->syms;
4119 sm->new_sym = new_symtree;
4120 sm->expr = gfc_copy_expr (expr);
4123 /* Stabilize the argument's value. */
4124 if (!sym->attr.function && se)
4125 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4127 if (sym->ts.type == BT_CHARACTER)
4129 /* Create a copy of the dummy argument's length. */
4130 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4131 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4133 /* If the length is specified as "*", record the length that
4134 the caller is passing. We should use the callee's length
4135 in all other cases. */
4136 if (!new_sym->ts.u.cl->length && se)
4138 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4139 new_sym->ts.u.cl->backend_decl = se->string_length;
4146 /* Use the passed value as-is if the argument is a function. */
4147 if (sym->attr.flavor == FL_PROCEDURE)
4150 /* If the argument is a pass-by-value scalar, use the value as is. */
4151 else if (!sym->attr.dimension && sym->attr.value)
4154 /* If the argument is either a string or a pointer to a string,
4155 convert it to a boundless character type. */
4156 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4158 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4159 tmp = build_pointer_type (tmp);
4160 if (sym->attr.pointer)
4161 value = build_fold_indirect_ref_loc (input_location,
4165 value = fold_convert (tmp, value);
4168 /* If the argument is a scalar, a pointer to an array or an allocatable,
4170 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4171 value = build_fold_indirect_ref_loc (input_location,
4174 /* For character(*), use the actual argument's descriptor. */
4175 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4176 value = build_fold_indirect_ref_loc (input_location,
4179 /* If the argument is an array descriptor, use it to determine
4180 information about the actual argument's shape. */
4181 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4182 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4184 /* Get the actual argument's descriptor. */
4185 desc = build_fold_indirect_ref_loc (input_location,
4188 /* Create the replacement variable. */
4189 tmp = gfc_conv_descriptor_data_get (desc);
4190 value = gfc_get_interface_mapping_array (&se->pre, sym,
4193 /* Use DESC to work out the upper bounds, strides and offset. */
4194 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4197 /* Otherwise we have a packed array. */
4198 value = gfc_get_interface_mapping_array (&se->pre, sym,
4199 PACKED_FULL, se->expr);
4201 new_sym->backend_decl = value;
4205 /* Called once all dummy argument mappings have been added to MAPPING,
4206 but before the mapping is used to evaluate expressions. Pre-evaluate
4207 the length of each argument, adding any initialization code to PRE and
4208 any finalization code to POST. */
4211 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4212 stmtblock_t * pre, stmtblock_t * post)
4214 gfc_interface_sym_mapping *sym;
4218 for (sym = mapping->syms; sym; sym = sym->next)
4219 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4220 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4222 expr = sym->new_sym->n.sym->ts.u.cl->length;
4223 gfc_apply_interface_mapping_to_expr (mapping, expr);
4224 gfc_init_se (&se, NULL);
4225 gfc_conv_expr (&se, expr);
4226 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4227 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4228 gfc_add_block_to_block (pre, &se.pre);
4229 gfc_add_block_to_block (post, &se.post);
4231 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4236 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4240 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4241 gfc_constructor_base base)
4244 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4246 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4249 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4250 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4251 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4257 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4261 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4266 for (; ref; ref = ref->next)
4270 for (n = 0; n < ref->u.ar.dimen; n++)
4272 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4273 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4274 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4283 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4284 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4290 /* Convert intrinsic function calls into result expressions. */
4293 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4301 arg1 = expr->value.function.actual->expr;
4302 if (expr->value.function.actual->next)
4303 arg2 = expr->value.function.actual->next->expr;
4307 sym = arg1->symtree->n.sym;
4309 if (sym->attr.dummy)
4314 switch (expr->value.function.isym->id)
4317 /* TODO figure out why this condition is necessary. */
4318 if (sym->attr.function
4319 && (arg1->ts.u.cl->length == NULL
4320 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4321 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4324 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4327 case GFC_ISYM_LEN_TRIM:
4328 new_expr = gfc_copy_expr (arg1);
4329 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4334 gfc_replace_expr (arg1, new_expr);
4338 if (!sym->as || sym->as->rank == 0)
4341 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4343 dup = mpz_get_si (arg2->value.integer);
4348 dup = sym->as->rank;
4352 for (; d < dup; d++)
4356 if (!sym->as->upper[d] || !sym->as->lower[d])
4358 gfc_free_expr (new_expr);
4362 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4363 gfc_get_int_expr (gfc_default_integer_kind,
4365 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4367 new_expr = gfc_multiply (new_expr, tmp);
4373 case GFC_ISYM_LBOUND:
4374 case GFC_ISYM_UBOUND:
4375 /* TODO These implementations of lbound and ubound do not limit if
4376 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4378 if (!sym->as || sym->as->rank == 0)
4381 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4382 d = mpz_get_si (arg2->value.integer) - 1;
4386 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4388 if (sym->as->lower[d])
4389 new_expr = gfc_copy_expr (sym->as->lower[d]);
4393 if (sym->as->upper[d])
4394 new_expr = gfc_copy_expr (sym->as->upper[d]);
4402 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4406 gfc_replace_expr (expr, new_expr);
4412 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4413 gfc_interface_mapping * mapping)
4415 gfc_formal_arglist *f;
4416 gfc_actual_arglist *actual;
4418 actual = expr->value.function.actual;
4419 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4421 for (; f && actual; f = f->next, actual = actual->next)
4426 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4429 if (map_expr->symtree->n.sym->attr.dimension)
4434 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4436 for (d = 0; d < as->rank; d++)
4438 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4439 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4442 expr->value.function.esym->as = as;
4445 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4447 expr->value.function.esym->ts.u.cl->length
4448 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4450 gfc_apply_interface_mapping_to_expr (mapping,
4451 expr->value.function.esym->ts.u.cl->length);
4456 /* EXPR is a copy of an expression that appeared in the interface
4457 associated with MAPPING. Walk it recursively looking for references to
4458 dummy arguments that MAPPING maps to actual arguments. Replace each such
4459 reference with a reference to the associated actual argument. */
4462 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4465 gfc_interface_sym_mapping *sym;
4466 gfc_actual_arglist *actual;
4471 /* Copying an expression does not copy its length, so do that here. */
4472 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4474 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4475 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4478 /* Apply the mapping to any references. */
4479 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4481 /* ...and to the expression's symbol, if it has one. */
4482 /* TODO Find out why the condition on expr->symtree had to be moved into
4483 the loop rather than being outside it, as originally. */
4484 for (sym = mapping->syms; sym; sym = sym->next)
4485 if (expr->symtree && sym->old == expr->symtree->n.sym)
4487 if (sym->new_sym->n.sym->backend_decl)
4488 expr->symtree = sym->new_sym;
4490 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4493 /* ...and to subexpressions in expr->value. */
4494 switch (expr->expr_type)
4499 case EXPR_SUBSTRING:
4503 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4504 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4508 for (actual = expr->value.function.actual; actual; actual = actual->next)
4509 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4511 if (expr->value.function.esym == NULL
4512 && expr->value.function.isym != NULL
4513 && expr->value.function.actual
4514 && expr->value.function.actual->expr
4515 && expr->value.function.actual->expr->symtree
4516 && gfc_map_intrinsic_function (expr, mapping))
4519 for (sym = mapping->syms; sym; sym = sym->next)
4520 if (sym->old == expr->value.function.esym)
4522 expr->value.function.esym = sym->new_sym->n.sym;
4523 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4524 expr->value.function.esym->result = sym->new_sym->n.sym;
4529 case EXPR_STRUCTURE:
4530 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4543 /* Evaluate interface expression EXPR using MAPPING. Store the result
4547 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4548 gfc_se * se, gfc_expr * expr)
4550 expr = gfc_copy_expr (expr);
4551 gfc_apply_interface_mapping_to_expr (mapping, expr);
4552 gfc_conv_expr (se, expr);
4553 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4554 gfc_free_expr (expr);
4558 /* Returns a reference to a temporary array into which a component of
4559 an actual argument derived type array is copied and then returned
4560 after the function call. */
4562 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4563 sym_intent intent, bool formal_ptr)
4571 gfc_array_info *info;
4581 gfc_init_se (&lse, NULL);
4582 gfc_init_se (&rse, NULL);
4584 /* Walk the argument expression. */
4585 rss = gfc_walk_expr (expr);
4587 gcc_assert (rss != gfc_ss_terminator);
4589 /* Initialize the scalarizer. */
4590 gfc_init_loopinfo (&loop);
4591 gfc_add_ss_to_loop (&loop, rss);
4593 /* Calculate the bounds of the scalarization. */
4594 gfc_conv_ss_startstride (&loop);
4596 /* Build an ss for the temporary. */
4597 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4598 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4600 base_type = gfc_typenode_for_spec (&expr->ts);
4601 if (GFC_ARRAY_TYPE_P (base_type)
4602 || GFC_DESCRIPTOR_TYPE_P (base_type))
4603 base_type = gfc_get_element_type (base_type);
4605 if (expr->ts.type == BT_CLASS)
4606 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4608 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4609 ? expr->ts.u.cl->backend_decl
4613 parmse->string_length = loop.temp_ss->info->string_length;
4615 /* Associate the SS with the loop. */
4616 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4618 /* Setup the scalarizing loops. */
4619 gfc_conv_loop_setup (&loop, &expr->where);
4621 /* Pass the temporary descriptor back to the caller. */
4622 info = &loop.temp_ss->info->data.array;
4623 parmse->expr = info->descriptor;
4625 /* Setup the gfc_se structures. */
4626 gfc_copy_loopinfo_to_se (&lse, &loop);
4627 gfc_copy_loopinfo_to_se (&rse, &loop);
4630 lse.ss = loop.temp_ss;
4631 gfc_mark_ss_chain_used (rss, 1);
4632 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4634 /* Start the scalarized loop body. */
4635 gfc_start_scalarized_body (&loop, &body);
4637 /* Translate the expression. */
4638 gfc_conv_expr (&rse, expr);
4640 /* Reset the offset for the function call since the loop
4641 is zero based on the data pointer. Note that the temp
4642 comes first in the loop chain since it is added second. */
4643 if (gfc_is_class_array_function (expr))
4645 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4646 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4647 gfc_index_zero_node);
4650 gfc_conv_tmp_array_ref (&lse);
4652 if (intent != INTENT_OUT)
4654 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4655 gfc_add_expr_to_block (&body, tmp);
4656 gcc_assert (rse.ss == gfc_ss_terminator);
4657 gfc_trans_scalarizing_loops (&loop, &body);
4661 /* Make sure that the temporary declaration survives by merging
4662 all the loop declarations into the current context. */
4663 for (n = 0; n < loop.dimen; n++)
4665 gfc_merge_block_scope (&body);
4666 body = loop.code[loop.order[n]];
4668 gfc_merge_block_scope (&body);
4671 /* Add the post block after the second loop, so that any
4672 freeing of allocated memory is done at the right time. */
4673 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4675 /**********Copy the temporary back again.*********/
4677 gfc_init_se (&lse, NULL);
4678 gfc_init_se (&rse, NULL);
4680 /* Walk the argument expression. */
4681 lss = gfc_walk_expr (expr);
4682 rse.ss = loop.temp_ss;
4685 /* Initialize the scalarizer. */
4686 gfc_init_loopinfo (&loop2);
4687 gfc_add_ss_to_loop (&loop2, lss);
4689 dimen = rse.ss->dimen;
4691 /* Skip the write-out loop for this case. */
4692 if (gfc_is_class_array_function (expr))
4693 goto class_array_fcn;
4695 /* Calculate the bounds of the scalarization. */
4696 gfc_conv_ss_startstride (&loop2);
4698 /* Setup the scalarizing loops. */
4699 gfc_conv_loop_setup (&loop2, &expr->where);
4701 gfc_copy_loopinfo_to_se (&lse, &loop2);
4702 gfc_copy_loopinfo_to_se (&rse, &loop2);
4704 gfc_mark_ss_chain_used (lss, 1);
4705 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4707 /* Declare the variable to hold the temporary offset and start the
4708 scalarized loop body. */
4709 offset = gfc_create_var (gfc_array_index_type, NULL);
4710 gfc_start_scalarized_body (&loop2, &body);
4712 /* Build the offsets for the temporary from the loop variables. The
4713 temporary array has lbounds of zero and strides of one in all
4714 dimensions, so this is very simple. The offset is only computed
4715 outside the innermost loop, so the overall transfer could be
4716 optimized further. */
4717 info = &rse.ss->info->data.array;
4719 tmp_index = gfc_index_zero_node;
4720 for (n = dimen - 1; n > 0; n--)
4723 tmp = rse.loop->loopvar[n];
4724 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4725 tmp, rse.loop->from[n]);
4726 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4729 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4730 gfc_array_index_type,
4731 rse.loop->to[n-1], rse.loop->from[n-1]);
4732 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4733 gfc_array_index_type,
4734 tmp_str, gfc_index_one_node);
4736 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4737 gfc_array_index_type, tmp, tmp_str);
4740 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4741 gfc_array_index_type,
4742 tmp_index, rse.loop->from[0]);
4743 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4745 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4746 gfc_array_index_type,
4747 rse.loop->loopvar[0], offset);
4749 /* Now use the offset for the reference. */
4750 tmp = build_fold_indirect_ref_loc (input_location,
4752 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4754 if (expr->ts.type == BT_CHARACTER)
4755 rse.string_length = expr->ts.u.cl->backend_decl;
4757 gfc_conv_expr (&lse, expr);
4759 gcc_assert (lse.ss == gfc_ss_terminator);
4761 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4762 gfc_add_expr_to_block (&body, tmp);
4764 /* Generate the copying loops. */
4765 gfc_trans_scalarizing_loops (&loop2, &body);
4767 /* Wrap the whole thing up by adding the second loop to the post-block
4768 and following it by the post-block of the first loop. In this way,
4769 if the temporary needs freeing, it is done after use! */
4770 if (intent != INTENT_IN)
4772 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4773 gfc_add_block_to_block (&parmse->post, &loop2.post);
4778 gfc_add_block_to_block (&parmse->post, &loop.post);
4780 gfc_cleanup_loop (&loop);
4781 gfc_cleanup_loop (&loop2);
4783 /* Pass the string length to the argument expression. */
4784 if (expr->ts.type == BT_CHARACTER)
4785 parmse->string_length = expr->ts.u.cl->backend_decl;
4787 /* Determine the offset for pointer formal arguments and set the
4791 size = gfc_index_one_node;
4792 offset = gfc_index_zero_node;
4793 for (n = 0; n < dimen; n++)
4795 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4797 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4798 gfc_array_index_type, tmp,
4799 gfc_index_one_node);
4800 gfc_conv_descriptor_ubound_set (&parmse->pre,
4804 gfc_conv_descriptor_lbound_set (&parmse->pre,
4807 gfc_index_one_node);
4808 size = gfc_evaluate_now (size, &parmse->pre);
4809 offset = fold_build2_loc (input_location, MINUS_EXPR,
4810 gfc_array_index_type,
4812 offset = gfc_evaluate_now (offset, &parmse->pre);
4813 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4814 gfc_array_index_type,
4815 rse.loop->to[n], rse.loop->from[n]);
4816 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4817 gfc_array_index_type,
4818 tmp, gfc_index_one_node);
4819 size = fold_build2_loc (input_location, MULT_EXPR,
4820 gfc_array_index_type, size, tmp);
4823 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4827 /* We want either the address for the data or the address of the descriptor,
4828 depending on the mode of passing array arguments. */
4830 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4832 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4838 /* Generate the code for argument list functions. */
4841 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4843 /* Pass by value for g77 %VAL(arg), pass the address
4844 indirectly for %LOC, else by reference. Thus %REF
4845 is a "do-nothing" and %LOC is the same as an F95
4847 if (strcmp (name, "%VAL") == 0)
4848 gfc_conv_expr (se, expr);
4849 else if (strcmp (name, "%LOC") == 0)
4851 gfc_conv_expr_reference (se, expr);
4852 se->expr = gfc_build_addr_expr (NULL, se->expr);
4854 else if (strcmp (name, "%REF") == 0)
4855 gfc_conv_expr_reference (se, expr);
4857 gfc_error ("Unknown argument list function at %L", &expr->where);
4861 /* This function tells whether the middle-end representation of the expression
4862 E given as input may point to data otherwise accessible through a variable
4864 It is assumed that the only expressions that may alias are variables,
4865 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4867 This function is used to decide whether freeing an expression's allocatable
4868 components is safe or should be avoided.
4870 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4871 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4872 is necessary because for array constructors, aliasing depends on how
4874 - If E is an array constructor used as argument to an elemental procedure,
4875 the array, which is generated through shallow copy by the scalarizer,
4876 is used directly and can alias the expressions it was copied from.
4877 - If E is an array constructor used as argument to a non-elemental
4878 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4879 the array as in the previous case, but then that array is used
4880 to initialize a new descriptor through deep copy. There is no alias
4881 possible in that case.
4882 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4886 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4890 if (e->expr_type == EXPR_VARIABLE)
4892 else if (e->expr_type == EXPR_FUNCTION)
4894 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4896 if (proc_ifc->result != NULL
4897 && ((proc_ifc->result->ts.type == BT_CLASS
4898 && proc_ifc->result->ts.u.derived->attr.is_class
4899 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4900 || proc_ifc->result->attr.pointer))
4905 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4908 for (c = gfc_constructor_first (e->value.constructor);
4909 c; c = gfc_constructor_next (c))
4911 && expr_may_alias_variables (c->expr, array_may_alias))
4918 /* Provide an interface between gfortran array descriptors and the F2018:18.4
4919 ISO_Fortran_binding array descriptors. */
4922 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
4927 tree ptr = NULL_TREE;
4931 symbol_attribute attr = gfc_expr_attr (e);
4933 /* If this is a full array or a scalar, the allocatable and pointer
4934 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
4936 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
4940 else if (attr.allocatable)
4946 gfc_conv_expr_descriptor (parmse, e);
4948 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
4949 parmse->expr = build_fold_indirect_ref_loc (input_location,
4952 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
4953 the expression type is different from the descriptor type, then
4954 the offset must be found (eg. to a component ref or substring)
4955 and the dtype updated. Assumed type entities are only allowed
4956 to be dummies in Fortran. They therefore lack the decl specific
4957 appendiges and so must be treated differently from other fortran
4958 entities passed to CFI descriptors in the interface decl. */
4959 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
4962 if (type && DECL_ARTIFICIAL (parmse->expr)
4963 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
4965 /* Obtain the offset to the data. */
4966 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
4967 gfc_index_zero_node, true, e);
4969 /* Update the dtype. */
4970 gfc_add_modify (&parmse->pre,
4971 gfc_conv_descriptor_dtype (parmse->expr),
4972 gfc_get_dtype_rank_type (e->rank, type));
4974 else if (type == NULL_TREE
4975 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
4977 /* Make sure that the span is set for expressions where it
4978 might not have been done already. */
4979 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
4980 tmp = fold_convert (gfc_array_index_type, tmp);
4981 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
4984 /* INTENT(IN) requires a temporary for the data. Assumed types do not
4985 work with the standard temporary generation schemes. */
4986 if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
4988 /* Fix the descriptor and determine the size of the data. */
4989 parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
4990 size = build_call_expr_loc (input_location,
4991 gfor_fndecl_size0, 1,
4992 gfc_build_addr_expr (NULL, parmse->expr));
4993 size = fold_convert (size_type_node, size);
4994 tmp = gfc_conv_descriptor_span_get (parmse->expr);
4995 tmp = fold_convert (size_type_node, tmp);
4996 size = fold_build2_loc (input_location, MULT_EXPR,
4997 size_type_node, size, tmp);
4998 /* Fix the size and allocate. */
4999 size = gfc_evaluate_now (size, &parmse->pre);
5000 tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
5001 ptr = build_call_expr_loc (input_location, tmp, 1, size);
5002 ptr = gfc_evaluate_now (ptr, &parmse->pre);
5003 /* Copy the data to the temporary descriptor. */
5004 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
5005 tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
5006 gfc_conv_descriptor_data_get (parmse->expr),
5008 gfc_add_expr_to_block (&parmse->pre, tmp);
5009 gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
5015 gfc_conv_expr (parmse, e);
5017 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5018 parmse->expr = build_fold_indirect_ref_loc (input_location,
5021 /* Copy the scalar for INTENT(IN). */
5022 if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
5023 parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
5024 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5025 parmse->expr, attr);
5028 /* Set the CFI attribute field. */
5029 tmp = gfc_conv_descriptor_attribute (parmse->expr);
5030 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5031 void_type_node, tmp,
5032 build_int_cst (TREE_TYPE (tmp), attribute));
5033 gfc_add_expr_to_block (&parmse->pre, tmp);
5035 /* Now pass the gfc_descriptor by reference. */
5036 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5038 /* Variables to point to the gfc and CFI descriptors. */
5039 gfc_desc_ptr = parmse->expr;
5040 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5042 /* Allocate the CFI descriptor and fill the fields. */
5043 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5044 tmp = build_call_expr_loc (input_location,
5045 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5046 gfc_add_expr_to_block (&parmse->pre, tmp);
5048 /* The CFI descriptor is passed to the bind_C procedure. */
5049 parmse->expr = cfi_desc_ptr;
5053 /* Free both the temporary data and the CFI descriptor for
5054 INTENT(IN) arrays. */
5055 tmp = gfc_call_free (ptr);
5056 gfc_prepend_expr_to_block (&parmse->post, tmp);
5057 tmp = gfc_call_free (cfi_desc_ptr);
5058 gfc_prepend_expr_to_block (&parmse->post, tmp);
5062 /* Transfer values back to gfc descriptor and free the CFI descriptor. */
5063 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5064 tmp = build_call_expr_loc (input_location,
5065 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5066 gfc_prepend_expr_to_block (&parmse->post, tmp);
5070 /* Generate code for a procedure call. Note can return se->post != NULL.
5071 If se->direct_byref is set then se->expr contains the return parameter.
5072 Return nonzero, if the call has alternate specifiers.
5073 'expr' is only needed for procedure pointer components. */
5076 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5077 gfc_actual_arglist * args, gfc_expr * expr,
5078 vec<tree, va_gc> *append_args)
5080 gfc_interface_mapping mapping;
5081 vec<tree, va_gc> *arglist;
5082 vec<tree, va_gc> *retargs;
5086 gfc_array_info *info;
5093 vec<tree, va_gc> *stringargs;
5094 vec<tree, va_gc> *optionalargs;
5096 gfc_formal_arglist *formal;
5097 gfc_actual_arglist *arg;
5098 int has_alternate_specifier = 0;
5099 bool need_interface_mapping;
5107 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5108 gfc_component *comp = NULL;
5115 optionalargs = NULL;
5120 comp = gfc_get_proc_ptr_comp (expr);
5122 bool elemental_proc = (comp
5123 && comp->ts.interface
5124 && comp->ts.interface->attr.elemental)
5125 || (comp && comp->attr.elemental)
5126 || sym->attr.elemental;
5130 if (!elemental_proc)
5132 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5133 if (se->ss->info->useflags)
5135 gcc_assert ((!comp && gfc_return_by_reference (sym)
5136 && sym->result->attr.dimension)
5137 || (comp && comp->attr.dimension)
5138 || gfc_is_class_array_function (expr));
5139 gcc_assert (se->loop != NULL);
5140 /* Access the previously obtained result. */
5141 gfc_conv_tmp_array_ref (se);
5145 info = &se->ss->info->data.array;
5150 gfc_init_block (&post);
5151 gfc_init_interface_mapping (&mapping);
5154 formal = gfc_sym_get_dummy_args (sym);
5155 need_interface_mapping = sym->attr.dimension ||
5156 (sym->ts.type == BT_CHARACTER
5157 && sym->ts.u.cl->length
5158 && sym->ts.u.cl->length->expr_type
5163 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5164 need_interface_mapping = comp->attr.dimension ||
5165 (comp->ts.type == BT_CHARACTER
5166 && comp->ts.u.cl->length
5167 && comp->ts.u.cl->length->expr_type
5171 base_object = NULL_TREE;
5172 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5173 is the third and fourth argument to such a function call a value
5174 denoting the number of elements to copy (i.e., most of the time the
5175 length of a deferred length string). */
5176 ulim_copy = (formal == NULL)
5177 && UNLIMITED_POLY (sym)
5178 && comp && (strcmp ("_copy", comp->name) == 0);
5180 /* Evaluate the arguments. */
5181 for (arg = args, argc = 0; arg != NULL;
5182 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5184 bool finalized = false;
5187 fsym = formal ? formal->sym : NULL;
5188 parm_kind = MISSING;
5190 /* If the procedure requires an explicit interface, the actual
5191 argument is passed according to the corresponding formal
5192 argument. If the corresponding formal argument is a POINTER,
5193 ALLOCATABLE or assumed shape, we do not use g77's calling
5194 convention, and pass the address of the array descriptor
5195 instead. Otherwise we use g77's calling convention, in other words
5196 pass the array data pointer without descriptor. */
5197 bool nodesc_arg = fsym != NULL
5198 && !(fsym->attr.pointer || fsym->attr.allocatable)
5200 && fsym->as->type != AS_ASSUMED_SHAPE
5201 && fsym->as->type != AS_ASSUMED_RANK;
5203 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5205 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5207 /* Class array expressions are sometimes coming completely unadorned
5208 with either arrayspec or _data component. Correct that here.
5209 OOP-TODO: Move this to the frontend. */
5210 if (e && e->expr_type == EXPR_VARIABLE
5212 && e->ts.type == BT_CLASS
5213 && (CLASS_DATA (e)->attr.codimension
5214 || CLASS_DATA (e)->attr.dimension))
5216 gfc_typespec temp_ts = e->ts;
5217 gfc_add_class_array_ref (e);
5223 if (se->ignore_optional)
5225 /* Some intrinsics have already been resolved to the correct
5229 else if (arg->label)
5231 has_alternate_specifier = 1;
5236 gfc_init_se (&parmse, NULL);
5238 /* For scalar arguments with VALUE attribute which are passed by
5239 value, pass "0" and a hidden argument gives the optional
5241 if (fsym && fsym->attr.optional && fsym->attr.value
5242 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5243 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5245 parmse.expr = fold_convert (gfc_sym_type (fsym),
5247 vec_safe_push (optionalargs, boolean_false_node);
5251 /* Pass a NULL pointer for an absent arg. */
5252 parmse.expr = null_pointer_node;
5253 if (arg->missing_arg_type == BT_CHARACTER)
5254 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5259 else if (arg->expr->expr_type == EXPR_NULL
5260 && fsym && !fsym->attr.pointer
5261 && (fsym->ts.type != BT_CLASS
5262 || !CLASS_DATA (fsym)->attr.class_pointer))
5264 /* Pass a NULL pointer to denote an absent arg. */
5265 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5266 && (fsym->ts.type != BT_CLASS
5267 || !CLASS_DATA (fsym)->attr.allocatable));
5268 gfc_init_se (&parmse, NULL);
5269 parmse.expr = null_pointer_node;
5270 if (arg->missing_arg_type == BT_CHARACTER)
5271 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5273 else if (fsym && fsym->ts.type == BT_CLASS
5274 && e->ts.type == BT_DERIVED)
5276 /* The derived type needs to be converted to a temporary
5278 gfc_init_se (&parmse, se);
5279 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5281 && e->expr_type == EXPR_VARIABLE
5282 && e->symtree->n.sym->attr.optional,
5283 CLASS_DATA (fsym)->attr.class_pointer
5284 || CLASS_DATA (fsym)->attr.allocatable);
5286 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5288 /* The intrinsic type needs to be converted to a temporary
5289 CLASS object for the unlimited polymorphic formal. */
5290 gfc_init_se (&parmse, se);
5291 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5293 else if (se->ss && se->ss->info->useflags)
5299 /* An elemental function inside a scalarized loop. */
5300 gfc_init_se (&parmse, se);
5301 parm_kind = ELEMENTAL;
5303 /* When no fsym is present, ulim_copy is set and this is a third or
5304 fourth argument, use call-by-value instead of by reference to
5305 hand the length properties to the copy routine (i.e., most of the
5306 time this will be a call to a __copy_character_* routine where the
5307 third and fourth arguments are the lengths of a deferred length
5309 if ((fsym && fsym->attr.value)
5310 || (ulim_copy && (argc == 2 || argc == 3)))
5311 gfc_conv_expr (&parmse, e);
5313 gfc_conv_expr_reference (&parmse, e);
5315 if (e->ts.type == BT_CHARACTER && !e->rank
5316 && e->expr_type == EXPR_FUNCTION)
5317 parmse.expr = build_fold_indirect_ref_loc (input_location,
5320 if (fsym && fsym->ts.type == BT_DERIVED
5321 && gfc_is_class_container_ref (e))
5323 parmse.expr = gfc_class_data_get (parmse.expr);
5325 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5326 && e->symtree->n.sym->attr.optional)
5328 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5329 parmse.expr = build3_loc (input_location, COND_EXPR,
5330 TREE_TYPE (parmse.expr),
5332 fold_convert (TREE_TYPE (parmse.expr),
5333 null_pointer_node));
5337 /* If we are passing an absent array as optional dummy to an
5338 elemental procedure, make sure that we pass NULL when the data
5339 pointer is NULL. We need this extra conditional because of
5340 scalarization which passes arrays elements to the procedure,
5341 ignoring the fact that the array can be absent/unallocated/... */
5342 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5344 tree descriptor_data;
5346 descriptor_data = ss->info->data.array.data;
5347 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5349 fold_convert (TREE_TYPE (descriptor_data),
5350 null_pointer_node));
5352 = fold_build3_loc (input_location, COND_EXPR,
5353 TREE_TYPE (parmse.expr),
5354 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5355 fold_convert (TREE_TYPE (parmse.expr),
5360 /* The scalarizer does not repackage the reference to a class
5361 array - instead it returns a pointer to the data element. */
5362 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5363 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5364 fsym->attr.intent != INTENT_IN
5365 && (CLASS_DATA (fsym)->attr.class_pointer
5366 || CLASS_DATA (fsym)->attr.allocatable),
5368 && e->expr_type == EXPR_VARIABLE
5369 && e->symtree->n.sym->attr.optional,
5370 CLASS_DATA (fsym)->attr.class_pointer
5371 || CLASS_DATA (fsym)->attr.allocatable);
5378 gfc_init_se (&parmse, NULL);
5380 /* Check whether the expression is a scalar or not; we cannot use
5381 e->rank as it can be nonzero for functions arguments. */
5382 argss = gfc_walk_expr (e);
5383 scalar = argss == gfc_ss_terminator;
5385 gfc_free_ss_chain (argss);
5387 /* Special handling for passing scalar polymorphic coarrays;
5388 otherwise one passes "class->_data.data" instead of "&class". */
5389 if (e->rank == 0 && e->ts.type == BT_CLASS
5390 && fsym && fsym->ts.type == BT_CLASS
5391 && CLASS_DATA (fsym)->attr.codimension
5392 && !CLASS_DATA (fsym)->attr.dimension)
5394 gfc_add_class_array_ref (e);
5395 parmse.want_coarray = 1;
5399 /* A scalar or transformational function. */
5402 if (e->expr_type == EXPR_VARIABLE
5403 && e->symtree->n.sym->attr.cray_pointee
5404 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5406 /* The Cray pointer needs to be converted to a pointer to
5407 a type given by the expression. */
5408 gfc_conv_expr (&parmse, e);
5409 type = build_pointer_type (TREE_TYPE (parmse.expr));
5410 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5411 parmse.expr = convert (type, tmp);
5414 else if (sym->attr.is_bind_c && e
5415 && fsym && fsym->attr.dimension
5416 && (fsym->as->type == AS_ASSUMED_RANK
5417 || fsym->as->type == AS_ASSUMED_SHAPE))
5418 /* Implement F2018, C.12.6.1: paragraph (2). */
5419 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5421 else if (fsym && fsym->attr.value)
5423 if (fsym->ts.type == BT_CHARACTER
5424 && fsym->ts.is_c_interop
5425 && fsym->ns->proc_name != NULL
5426 && fsym->ns->proc_name->attr.is_bind_c)
5429 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5430 if (parmse.expr == NULL)
5431 gfc_conv_expr (&parmse, e);
5435 gfc_conv_expr (&parmse, e);
5436 if (fsym->attr.optional
5437 && fsym->ts.type != BT_CLASS
5438 && fsym->ts.type != BT_DERIVED)
5440 if (e->expr_type != EXPR_VARIABLE
5441 || !e->symtree->n.sym->attr.optional
5443 vec_safe_push (optionalargs, boolean_true_node);
5446 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5447 if (!e->symtree->n.sym->attr.value)
5449 = fold_build3_loc (input_location, COND_EXPR,
5450 TREE_TYPE (parmse.expr),
5452 fold_convert (TREE_TYPE (parmse.expr),
5453 integer_zero_node));
5455 vec_safe_push (optionalargs, tmp);
5461 else if (arg->name && arg->name[0] == '%')
5462 /* Argument list functions %VAL, %LOC and %REF are signalled
5463 through arg->name. */
5464 conv_arglist_function (&parmse, arg->expr, arg->name);
5465 else if ((e->expr_type == EXPR_FUNCTION)
5466 && ((e->value.function.esym
5467 && e->value.function.esym->result->attr.pointer)
5468 || (!e->value.function.esym
5469 && e->symtree->n.sym->attr.pointer))
5470 && fsym && fsym->attr.target)
5472 gfc_conv_expr (&parmse, e);
5473 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5476 else if (e->expr_type == EXPR_FUNCTION
5477 && e->symtree->n.sym->result
5478 && e->symtree->n.sym->result != e->symtree->n.sym
5479 && e->symtree->n.sym->result->attr.proc_pointer)
5481 /* Functions returning procedure pointers. */
5482 gfc_conv_expr (&parmse, e);
5483 if (fsym && fsym->attr.proc_pointer)
5484 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5489 if (e->ts.type == BT_CLASS && fsym
5490 && fsym->ts.type == BT_CLASS
5491 && (!CLASS_DATA (fsym)->as
5492 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5493 && CLASS_DATA (e)->attr.codimension)
5495 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5496 gcc_assert (!CLASS_DATA (fsym)->as);
5497 gfc_add_class_array_ref (e);
5498 parmse.want_coarray = 1;
5499 gfc_conv_expr_reference (&parmse, e);
5500 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5502 && e->expr_type == EXPR_VARIABLE);
5504 else if (e->ts.type == BT_CLASS && fsym
5505 && fsym->ts.type == BT_CLASS
5506 && !CLASS_DATA (fsym)->as
5507 && !CLASS_DATA (e)->as
5508 && strcmp (fsym->ts.u.derived->name,
5509 e->ts.u.derived->name))
5511 type = gfc_typenode_for_spec (&fsym->ts);
5512 var = gfc_create_var (type, fsym->name);
5513 gfc_conv_expr (&parmse, e);
5514 if (fsym->attr.optional
5515 && e->expr_type == EXPR_VARIABLE
5516 && e->symtree->n.sym->attr.optional)
5520 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5521 cond = fold_build2_loc (input_location, NE_EXPR,
5522 logical_type_node, tmp,
5523 fold_convert (TREE_TYPE (tmp),
5524 null_pointer_node));
5525 gfc_start_block (&block);
5526 gfc_add_modify (&block, var,
5527 fold_build1_loc (input_location,
5529 type, parmse.expr));
5530 gfc_add_expr_to_block (&parmse.pre,
5531 fold_build3_loc (input_location,
5532 COND_EXPR, void_type_node,
5533 cond, gfc_finish_block (&block),
5534 build_empty_stmt (input_location)));
5535 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5536 parmse.expr = build3_loc (input_location, COND_EXPR,
5537 TREE_TYPE (parmse.expr),
5539 fold_convert (TREE_TYPE (parmse.expr),
5540 null_pointer_node));
5544 /* Since the internal representation of unlimited
5545 polymorphic expressions includes an extra field
5546 that other class objects do not, a cast to the
5547 formal type does not work. */
5548 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5552 /* Set the _data field. */
5553 tmp = gfc_class_data_get (var);
5554 efield = fold_convert (TREE_TYPE (tmp),
5555 gfc_class_data_get (parmse.expr));
5556 gfc_add_modify (&parmse.pre, tmp, efield);
5558 /* Set the _vptr field. */
5559 tmp = gfc_class_vptr_get (var);
5560 efield = fold_convert (TREE_TYPE (tmp),
5561 gfc_class_vptr_get (parmse.expr));
5562 gfc_add_modify (&parmse.pre, tmp, efield);
5564 /* Set the _len field. */
5565 tmp = gfc_class_len_get (var);
5566 gfc_add_modify (&parmse.pre, tmp,
5567 build_int_cst (TREE_TYPE (tmp), 0));
5571 tmp = fold_build1_loc (input_location,
5574 gfc_add_modify (&parmse.pre, var, tmp);
5577 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5583 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5584 && !fsym->attr.allocatable && !fsym->attr.pointer
5585 && !e->symtree->n.sym->attr.dimension
5586 && !e->symtree->n.sym->attr.pointer
5588 && !e->symtree->n.sym->attr.dummy
5589 /* FIXME - PR 87395 and PR 41453 */
5590 && e->symtree->n.sym->attr.save == SAVE_NONE
5591 && !e->symtree->n.sym->attr.associate_var
5592 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5593 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5595 gfc_conv_expr_reference (&parmse, e, add_clobber);
5597 /* Catch base objects that are not variables. */
5598 if (e->ts.type == BT_CLASS
5599 && e->expr_type != EXPR_VARIABLE
5600 && expr && e == expr->base_expr)
5601 base_object = build_fold_indirect_ref_loc (input_location,
5604 /* A class array element needs converting back to be a
5605 class object, if the formal argument is a class object. */
5606 if (fsym && fsym->ts.type == BT_CLASS
5607 && e->ts.type == BT_CLASS
5608 && ((CLASS_DATA (fsym)->as
5609 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5610 || CLASS_DATA (e)->attr.dimension))
5611 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5612 fsym->attr.intent != INTENT_IN
5613 && (CLASS_DATA (fsym)->attr.class_pointer
5614 || CLASS_DATA (fsym)->attr.allocatable),
5616 && e->expr_type == EXPR_VARIABLE
5617 && e->symtree->n.sym->attr.optional,
5618 CLASS_DATA (fsym)->attr.class_pointer
5619 || CLASS_DATA (fsym)->attr.allocatable);
5621 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5622 allocated on entry, it must be deallocated. */
5623 if (fsym && fsym->attr.intent == INTENT_OUT
5624 && (fsym->attr.allocatable
5625 || (fsym->ts.type == BT_CLASS
5626 && CLASS_DATA (fsym)->attr.allocatable)))
5631 gfc_init_block (&block);
5633 if (e->ts.type == BT_CLASS)
5634 ptr = gfc_class_data_get (ptr);
5636 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5639 gfc_add_expr_to_block (&block, tmp);
5640 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5641 void_type_node, ptr,
5643 gfc_add_expr_to_block (&block, tmp);
5645 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5647 gfc_add_modify (&block, ptr,
5648 fold_convert (TREE_TYPE (ptr),
5649 null_pointer_node));
5650 gfc_add_expr_to_block (&block, tmp);
5652 else if (fsym->ts.type == BT_CLASS)
5655 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5656 tmp = gfc_get_symbol_decl (vtab);
5657 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5658 ptr = gfc_class_vptr_get (parmse.expr);
5659 gfc_add_modify (&block, ptr,
5660 fold_convert (TREE_TYPE (ptr), tmp));
5661 gfc_add_expr_to_block (&block, tmp);
5664 if (fsym->attr.optional
5665 && e->expr_type == EXPR_VARIABLE
5666 && e->symtree->n.sym->attr.optional)
5668 tmp = fold_build3_loc (input_location, COND_EXPR,
5670 gfc_conv_expr_present (e->symtree->n.sym),
5671 gfc_finish_block (&block),
5672 build_empty_stmt (input_location));
5675 tmp = gfc_finish_block (&block);
5677 gfc_add_expr_to_block (&se->pre, tmp);
5680 if (fsym && (fsym->ts.type == BT_DERIVED
5681 || fsym->ts.type == BT_ASSUMED)
5682 && e->ts.type == BT_CLASS
5683 && !CLASS_DATA (e)->attr.dimension
5684 && !CLASS_DATA (e)->attr.codimension)
5686 parmse.expr = gfc_class_data_get (parmse.expr);
5687 /* The result is a class temporary, whose _data component
5688 must be freed to avoid a memory leak. */
5689 if (e->expr_type == EXPR_FUNCTION
5690 && CLASS_DATA (e)->attr.allocatable)
5696 /* Borrow the function symbol to make a call to
5697 gfc_add_finalizer_call and then restore it. */
5698 tmp = e->symtree->n.sym->backend_decl;
5699 e->symtree->n.sym->backend_decl
5700 = TREE_OPERAND (parmse.expr, 0);
5701 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5702 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5703 finalized = gfc_add_finalizer_call (&parmse.post,
5705 gfc_free_expr (var);
5706 e->symtree->n.sym->backend_decl = tmp;
5707 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5709 /* Then free the class _data. */
5710 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5711 tmp = fold_build2_loc (input_location, NE_EXPR,
5714 tmp = build3_v (COND_EXPR, tmp,
5715 gfc_call_free (parmse.expr),
5716 build_empty_stmt (input_location));
5717 gfc_add_expr_to_block (&parmse.post, tmp);
5718 gfc_add_modify (&parmse.post, parmse.expr, zero);
5722 /* Wrap scalar variable in a descriptor. We need to convert
5723 the address of a pointer back to the pointer itself before,
5724 we can assign it to the data field. */
5726 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5727 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5730 if (TREE_CODE (tmp) == ADDR_EXPR)
5731 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5732 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5734 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5737 else if (fsym && e->expr_type != EXPR_NULL
5738 && ((fsym->attr.pointer
5739 && fsym->attr.flavor != FL_PROCEDURE)
5740 || (fsym->attr.proc_pointer
5741 && !(e->expr_type == EXPR_VARIABLE
5742 && e->symtree->n.sym->attr.dummy))
5743 || (fsym->attr.proc_pointer
5744 && e->expr_type == EXPR_VARIABLE
5745 && gfc_is_proc_ptr_comp (e))
5746 || (fsym->attr.allocatable
5747 && fsym->attr.flavor != FL_PROCEDURE)))
5749 /* Scalar pointer dummy args require an extra level of
5750 indirection. The null pointer already contains
5751 this level of indirection. */
5752 parm_kind = SCALAR_POINTER;
5753 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5757 else if (e->ts.type == BT_CLASS
5758 && fsym && fsym->ts.type == BT_CLASS
5759 && (CLASS_DATA (fsym)->attr.dimension
5760 || CLASS_DATA (fsym)->attr.codimension))
5762 /* Pass a class array. */
5763 parmse.use_offset = 1;
5764 gfc_conv_expr_descriptor (&parmse, e);
5766 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5767 allocated on entry, it must be deallocated. */
5768 if (fsym->attr.intent == INTENT_OUT
5769 && CLASS_DATA (fsym)->attr.allocatable)
5774 gfc_init_block (&block);
5776 ptr = gfc_class_data_get (ptr);
5778 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5779 NULL_TREE, NULL_TREE,
5781 GFC_CAF_COARRAY_NOCOARRAY);
5782 gfc_add_expr_to_block (&block, tmp);
5783 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5784 void_type_node, ptr,
5786 gfc_add_expr_to_block (&block, tmp);
5787 gfc_reset_vptr (&block, e);
5789 if (fsym->attr.optional
5790 && e->expr_type == EXPR_VARIABLE
5792 || (e->ref->type == REF_ARRAY
5793 && e->ref->u.ar.type != AR_FULL))
5794 && e->symtree->n.sym->attr.optional)
5796 tmp = fold_build3_loc (input_location, COND_EXPR,
5798 gfc_conv_expr_present (e->symtree->n.sym),
5799 gfc_finish_block (&block),
5800 build_empty_stmt (input_location));
5803 tmp = gfc_finish_block (&block);
5805 gfc_add_expr_to_block (&se->pre, tmp);
5808 /* The conversion does not repackage the reference to a class
5809 array - _data descriptor. */
5810 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5811 fsym->attr.intent != INTENT_IN
5812 && (CLASS_DATA (fsym)->attr.class_pointer
5813 || CLASS_DATA (fsym)->attr.allocatable),
5815 && e->expr_type == EXPR_VARIABLE
5816 && e->symtree->n.sym->attr.optional,
5817 CLASS_DATA (fsym)->attr.class_pointer
5818 || CLASS_DATA (fsym)->attr.allocatable);
5822 /* If the argument is a function call that may not create
5823 a temporary for the result, we have to check that we
5824 can do it, i.e. that there is no alias between this
5825 argument and another one. */
5826 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5832 intent = fsym->attr.intent;
5834 intent = INTENT_UNKNOWN;
5836 if (gfc_check_fncall_dependency (e, intent, sym, args,
5838 parmse.force_tmp = 1;
5840 iarg = e->value.function.actual->expr;
5842 /* Temporary needed if aliasing due to host association. */
5843 if (sym->attr.contained
5845 && !sym->attr.implicit_pure
5846 && !sym->attr.use_assoc
5847 && iarg->expr_type == EXPR_VARIABLE
5848 && sym->ns == iarg->symtree->n.sym->ns)
5849 parmse.force_tmp = 1;
5851 /* Ditto within module. */
5852 if (sym->attr.use_assoc
5854 && !sym->attr.implicit_pure
5855 && iarg->expr_type == EXPR_VARIABLE
5856 && sym->module == iarg->symtree->n.sym->module)
5857 parmse.force_tmp = 1;
5860 if (sym->attr.is_bind_c && e
5861 && fsym && fsym->attr.dimension
5862 && (fsym->as->type == AS_ASSUMED_RANK
5863 || fsym->as->type == AS_ASSUMED_SHAPE))
5864 /* Implement F2018, C.12.6.1: paragraph (2). */
5865 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5867 else if (e->expr_type == EXPR_VARIABLE
5868 && is_subref_array (e)
5869 && !(fsym && fsym->attr.pointer))
5870 /* The actual argument is a component reference to an
5871 array of derived types. In this case, the argument
5872 is converted to a temporary, which is passed and then
5873 written back after the procedure call. */
5874 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5875 fsym ? fsym->attr.intent : INTENT_INOUT,
5876 fsym && fsym->attr.pointer);
5878 else if (gfc_is_class_array_ref (e, NULL)
5879 && fsym && fsym->ts.type == BT_DERIVED)
5880 /* The actual argument is a component reference to an
5881 array of derived types. In this case, the argument
5882 is converted to a temporary, which is passed and then
5883 written back after the procedure call.
5884 OOP-TODO: Insert code so that if the dynamic type is
5885 the same as the declared type, copy-in/copy-out does
5887 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5888 fsym ? fsym->attr.intent : INTENT_INOUT,
5889 fsym && fsym->attr.pointer);
5891 else if (gfc_is_class_array_function (e)
5892 && fsym && fsym->ts.type == BT_DERIVED)
5893 /* See previous comment. For function actual argument,
5894 the write out is not needed so the intent is set as
5897 e->must_finalize = 1;
5898 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5900 fsym && fsym->attr.pointer);
5902 else if (fsym && fsym->attr.contiguous
5903 && !gfc_is_simply_contiguous (e, false, true))
5905 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5906 fsym ? fsym->attr.intent : INTENT_INOUT,
5907 fsym && fsym->attr.pointer);
5910 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5913 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5914 allocated on entry, it must be deallocated. */
5915 if (fsym && fsym->attr.allocatable
5916 && fsym->attr.intent == INTENT_OUT)
5918 if (fsym->ts.type == BT_DERIVED
5919 && fsym->ts.u.derived->attr.alloc_comp)
5921 // deallocate the components first
5922 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5923 parmse.expr, e->rank);
5924 if (tmp != NULL_TREE)
5925 gfc_add_expr_to_block (&se->pre, tmp);
5928 tmp = build_fold_indirect_ref_loc (input_location,
5930 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5931 tmp = gfc_conv_descriptor_data_get (tmp);
5932 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5933 NULL_TREE, NULL_TREE, true,
5935 GFC_CAF_COARRAY_NOCOARRAY);
5936 if (fsym->attr.optional
5937 && e->expr_type == EXPR_VARIABLE
5938 && e->symtree->n.sym->attr.optional)
5939 tmp = fold_build3_loc (input_location, COND_EXPR,
5941 gfc_conv_expr_present (e->symtree->n.sym),
5942 tmp, build_empty_stmt (input_location));
5943 gfc_add_expr_to_block (&se->pre, tmp);
5948 /* The case with fsym->attr.optional is that of a user subroutine
5949 with an interface indicating an optional argument. When we call
5950 an intrinsic subroutine, however, fsym is NULL, but we might still
5951 have an optional argument, so we proceed to the substitution
5953 if (e && (fsym == NULL || fsym->attr.optional))
5955 /* If an optional argument is itself an optional dummy argument,
5956 check its presence and substitute a null if absent. This is
5957 only needed when passing an array to an elemental procedure
5958 as then array elements are accessed - or no NULL pointer is
5959 allowed and a "1" or "0" should be passed if not present.
5960 When passing a non-array-descriptor full array to a
5961 non-array-descriptor dummy, no check is needed. For
5962 array-descriptor actual to array-descriptor dummy, see
5963 PR 41911 for why a check has to be inserted.
5964 fsym == NULL is checked as intrinsics required the descriptor
5965 but do not always set fsym.
5966 Also, it is necessary to pass a NULL pointer to library routines
5967 which usually ignore optional arguments, so they can handle
5968 these themselves. */
5969 if (e->expr_type == EXPR_VARIABLE
5970 && e->symtree->n.sym->attr.optional
5971 && (((e->rank != 0 && elemental_proc)
5972 || e->representation.length || e->ts.type == BT_CHARACTER
5976 && (fsym->as->type == AS_ASSUMED_SHAPE
5977 || fsym->as->type == AS_ASSUMED_RANK
5978 || fsym->as->type == AS_DEFERRED)))))
5979 || se->ignore_optional))
5980 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5981 e->representation.length);
5986 /* Obtain the character length of an assumed character length
5987 length procedure from the typespec. */
5988 if (fsym->ts.type == BT_CHARACTER
5989 && parmse.string_length == NULL_TREE
5990 && e->ts.type == BT_PROCEDURE
5991 && e->symtree->n.sym->ts.type == BT_CHARACTER
5992 && e->symtree->n.sym->ts.u.cl->length != NULL
5993 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5995 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5996 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6000 if (fsym && need_interface_mapping && e)
6001 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6003 gfc_add_block_to_block (&se->pre, &parmse.pre);
6004 gfc_add_block_to_block (&post, &parmse.post);
6006 /* Allocated allocatable components of derived types must be
6007 deallocated for non-variable scalars, array arguments to elemental
6008 procedures, and array arguments with descriptor to non-elemental
6009 procedures. As bounds information for descriptorless arrays is no
6010 longer available here, they are dealt with in trans-array.c
6011 (gfc_conv_array_parameter). */
6012 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6013 && e->ts.u.derived->attr.alloc_comp
6014 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6015 && !expr_may_alias_variables (e, elemental_proc))
6018 /* It is known the e returns a structure type with at least one
6019 allocatable component. When e is a function, ensure that the
6020 function is called once only by using a temporary variable. */
6021 if (!DECL_P (parmse.expr))
6022 parmse.expr = gfc_evaluate_now_loc (input_location,
6023 parmse.expr, &se->pre);
6025 if (fsym && fsym->attr.value)
6028 tmp = build_fold_indirect_ref_loc (input_location,
6031 parm_rank = e->rank;
6039 case (SCALAR_POINTER):
6040 tmp = build_fold_indirect_ref_loc (input_location,
6045 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6047 /* The derived type is passed to gfc_deallocate_alloc_comp.
6048 Therefore, class actuals can be handled correctly but derived
6049 types passed to class formals need the _data component. */
6050 tmp = gfc_class_data_get (tmp);
6051 if (!CLASS_DATA (fsym)->attr.dimension)
6052 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6055 if (e->expr_type == EXPR_OP
6056 && e->value.op.op == INTRINSIC_PARENTHESES
6057 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6060 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6061 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6063 gfc_add_expr_to_block (&se->post, local_tmp);
6066 if (!finalized && !e->must_finalize)
6068 if ((e->ts.type == BT_CLASS
6069 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6070 || e->ts.type == BT_DERIVED)
6071 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6073 else if (e->ts.type == BT_CLASS)
6074 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6076 gfc_prepend_expr_to_block (&post, tmp);
6080 /* Add argument checking of passing an unallocated/NULL actual to
6081 a nonallocatable/nonpointer dummy. */
6083 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6085 symbol_attribute attr;
6089 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6090 attr = gfc_expr_attr (e);
6092 goto end_pointer_check;
6094 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6095 allocatable to an optional dummy, cf. 12.5.2.12. */
6096 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6097 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6098 goto end_pointer_check;
6102 /* If the actual argument is an optional pointer/allocatable and
6103 the formal argument takes an nonpointer optional value,
6104 it is invalid to pass a non-present argument on, even
6105 though there is no technical reason for this in gfortran.
6106 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6107 tree present, null_ptr, type;
6109 if (attr.allocatable
6110 && (fsym == NULL || !fsym->attr.allocatable))
6111 msg = xasprintf ("Allocatable actual argument '%s' is not "
6112 "allocated or not present",
6113 e->symtree->n.sym->name);
6114 else if (attr.pointer
6115 && (fsym == NULL || !fsym->attr.pointer))
6116 msg = xasprintf ("Pointer actual argument '%s' is not "
6117 "associated or not present",
6118 e->symtree->n.sym->name);
6119 else if (attr.proc_pointer
6120 && (fsym == NULL || !fsym->attr.proc_pointer))
6121 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6122 "associated or not present",
6123 e->symtree->n.sym->name);
6125 goto end_pointer_check;
6127 present = gfc_conv_expr_present (e->symtree->n.sym);
6128 type = TREE_TYPE (present);
6129 present = fold_build2_loc (input_location, EQ_EXPR,
6130 logical_type_node, present,
6132 null_pointer_node));
6133 type = TREE_TYPE (parmse.expr);
6134 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6135 logical_type_node, parmse.expr,
6137 null_pointer_node));
6138 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6139 logical_type_node, present, null_ptr);
6143 if (attr.allocatable
6144 && (fsym == NULL || !fsym->attr.allocatable))
6145 msg = xasprintf ("Allocatable actual argument '%s' is not "
6146 "allocated", e->symtree->n.sym->name);
6147 else if (attr.pointer
6148 && (fsym == NULL || !fsym->attr.pointer))
6149 msg = xasprintf ("Pointer actual argument '%s' is not "
6150 "associated", e->symtree->n.sym->name);
6151 else if (attr.proc_pointer
6152 && (fsym == NULL || !fsym->attr.proc_pointer))
6153 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6154 "associated", e->symtree->n.sym->name);
6156 goto end_pointer_check;
6160 /* If the argument is passed by value, we need to strip the
6162 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6163 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6165 cond = fold_build2_loc (input_location, EQ_EXPR,
6166 logical_type_node, tmp,
6167 fold_convert (TREE_TYPE (tmp),
6168 null_pointer_node));
6171 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6177 /* Deferred length dummies pass the character length by reference
6178 so that the value can be returned. */
6179 if (parmse.string_length && fsym && fsym->ts.deferred)
6181 if (INDIRECT_REF_P (parmse.string_length))
6182 /* In chains of functions/procedure calls the string_length already
6183 is a pointer to the variable holding the length. Therefore
6184 remove the deref on call. */
6185 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6188 tmp = parmse.string_length;
6189 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6190 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6191 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6195 /* Character strings are passed as two parameters, a length and a
6196 pointer - except for Bind(c) which only passes the pointer.
6197 An unlimited polymorphic formal argument likewise does not
6199 if (parmse.string_length != NULL_TREE
6200 && !sym->attr.is_bind_c
6201 && !(fsym && UNLIMITED_POLY (fsym)))
6202 vec_safe_push (stringargs, parmse.string_length);
6204 /* When calling __copy for character expressions to unlimited
6205 polymorphic entities, the dst argument needs a string length. */
6206 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6207 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6208 && arg->next && arg->next->expr
6209 && (arg->next->expr->ts.type == BT_DERIVED
6210 || arg->next->expr->ts.type == BT_CLASS)
6211 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6212 vec_safe_push (stringargs, parmse.string_length);
6214 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6215 pass the token and the offset as additional arguments. */
6216 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6217 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6218 && !fsym->attr.allocatable)
6219 || (fsym->ts.type == BT_CLASS
6220 && CLASS_DATA (fsym)->attr.codimension
6221 && !CLASS_DATA (fsym)->attr.allocatable)))
6223 /* Token and offset. */
6224 vec_safe_push (stringargs, null_pointer_node);
6225 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6226 gcc_assert (fsym->attr.optional);
6228 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6229 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6230 && !fsym->attr.allocatable)
6231 || (fsym->ts.type == BT_CLASS
6232 && CLASS_DATA (fsym)->attr.codimension
6233 && !CLASS_DATA (fsym)->attr.allocatable)))
6235 tree caf_decl, caf_type;
6238 caf_decl = gfc_get_tree_for_caf_expr (e);
6239 caf_type = TREE_TYPE (caf_decl);
6241 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6242 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6243 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6244 tmp = gfc_conv_descriptor_token (caf_decl);
6245 else if (DECL_LANG_SPECIFIC (caf_decl)
6246 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6247 tmp = GFC_DECL_TOKEN (caf_decl);
6250 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6251 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6252 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6255 vec_safe_push (stringargs, tmp);
6257 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6258 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6259 offset = build_int_cst (gfc_array_index_type, 0);
6260 else if (DECL_LANG_SPECIFIC (caf_decl)
6261 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6262 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6263 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6264 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6266 offset = build_int_cst (gfc_array_index_type, 0);
6268 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6269 tmp = gfc_conv_descriptor_data_get (caf_decl);
6272 gcc_assert (POINTER_TYPE_P (caf_type));
6276 tmp2 = fsym->ts.type == BT_CLASS
6277 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6278 if ((fsym->ts.type != BT_CLASS
6279 && (fsym->as->type == AS_ASSUMED_SHAPE
6280 || fsym->as->type == AS_ASSUMED_RANK))
6281 || (fsym->ts.type == BT_CLASS
6282 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6283 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6285 if (fsym->ts.type == BT_CLASS)
6286 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6289 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6290 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6292 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6293 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6295 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6296 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6299 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6302 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6303 gfc_array_index_type,
6304 fold_convert (gfc_array_index_type, tmp2),
6305 fold_convert (gfc_array_index_type, tmp));
6306 offset = fold_build2_loc (input_location, PLUS_EXPR,
6307 gfc_array_index_type, offset, tmp);
6309 vec_safe_push (stringargs, offset);
6312 vec_safe_push (arglist, parmse.expr);
6314 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6318 else if (sym->ts.type == BT_CLASS)
6319 ts = CLASS_DATA (sym)->ts;
6323 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6324 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6325 else if (ts.type == BT_CHARACTER)
6327 if (ts.u.cl->length == NULL)
6329 /* Assumed character length results are not allowed by C418 of the 2003
6330 standard and are trapped in resolve.c; except in the case of SPREAD
6331 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6332 we take the character length of the first argument for the result.
6333 For dummies, we have to look through the formal argument list for
6334 this function and use the character length found there.*/
6336 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6337 else if (!sym->attr.dummy)
6338 cl.backend_decl = (*stringargs)[0];
6341 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6342 for (; formal; formal = formal->next)
6343 if (strcmp (formal->sym->name, sym->name) == 0)
6344 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6346 len = cl.backend_decl;
6352 /* Calculate the length of the returned string. */
6353 gfc_init_se (&parmse, NULL);
6354 if (need_interface_mapping)
6355 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6357 gfc_conv_expr (&parmse, ts.u.cl->length);
6358 gfc_add_block_to_block (&se->pre, &parmse.pre);
6359 gfc_add_block_to_block (&se->post, &parmse.post);
6361 /* TODO: It would be better to have the charlens as
6362 gfc_charlen_type_node already when the interface is
6363 created instead of converting it here (see PR 84615). */
6364 tmp = fold_build2_loc (input_location, MAX_EXPR,
6365 gfc_charlen_type_node,
6366 fold_convert (gfc_charlen_type_node, tmp),
6367 build_zero_cst (gfc_charlen_type_node));
6368 cl.backend_decl = tmp;
6371 /* Set up a charlen structure for it. */
6376 len = cl.backend_decl;
6379 byref = (comp && (comp->attr.dimension
6380 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6381 || (!comp && gfc_return_by_reference (sym));
6384 if (se->direct_byref)
6386 /* Sometimes, too much indirection can be applied; e.g. for
6387 function_result = array_valued_recursive_function. */
6388 if (TREE_TYPE (TREE_TYPE (se->expr))
6389 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6390 && GFC_DESCRIPTOR_TYPE_P
6391 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6392 se->expr = build_fold_indirect_ref_loc (input_location,
6395 /* If the lhs of an assignment x = f(..) is allocatable and
6396 f2003 is allowed, we must do the automatic reallocation.
6397 TODO - deal with intrinsics, without using a temporary. */
6398 if (flag_realloc_lhs
6399 && se->ss && se->ss->loop_chain
6400 && se->ss->loop_chain->is_alloc_lhs
6401 && !expr->value.function.isym
6402 && sym->result->as != NULL)
6404 /* Evaluate the bounds of the result, if known. */
6405 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6408 /* Perform the automatic reallocation. */
6409 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6411 gfc_add_expr_to_block (&se->pre, tmp);
6413 /* Pass the temporary as the first argument. */
6414 result = info->descriptor;
6417 result = build_fold_indirect_ref_loc (input_location,
6419 vec_safe_push (retargs, se->expr);
6421 else if (comp && comp->attr.dimension)
6423 gcc_assert (se->loop && info);
6425 /* Set the type of the array. */
6426 tmp = gfc_typenode_for_spec (&comp->ts);
6427 gcc_assert (se->ss->dimen == se->loop->dimen);
6429 /* Evaluate the bounds of the result, if known. */
6430 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6432 /* If the lhs of an assignment x = f(..) is allocatable and
6433 f2003 is allowed, we must not generate the function call
6434 here but should just send back the results of the mapping.
6435 This is signalled by the function ss being flagged. */
6436 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6438 gfc_free_interface_mapping (&mapping);
6439 return has_alternate_specifier;
6442 /* Create a temporary to store the result. In case the function
6443 returns a pointer, the temporary will be a shallow copy and
6444 mustn't be deallocated. */
6445 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6446 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6447 tmp, NULL_TREE, false,
6448 !comp->attr.pointer, callee_alloc,
6449 &se->ss->info->expr->where);
6451 /* Pass the temporary as the first argument. */
6452 result = info->descriptor;
6453 tmp = gfc_build_addr_expr (NULL_TREE, result);
6454 vec_safe_push (retargs, tmp);
6456 else if (!comp && sym->result->attr.dimension)
6458 gcc_assert (se->loop && info);
6460 /* Set the type of the array. */
6461 tmp = gfc_typenode_for_spec (&ts);
6462 gcc_assert (se->ss->dimen == se->loop->dimen);
6464 /* Evaluate the bounds of the result, if known. */
6465 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6467 /* If the lhs of an assignment x = f(..) is allocatable and
6468 f2003 is allowed, we must not generate the function call
6469 here but should just send back the results of the mapping.
6470 This is signalled by the function ss being flagged. */
6471 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6473 gfc_free_interface_mapping (&mapping);
6474 return has_alternate_specifier;
6477 /* Create a temporary to store the result. In case the function
6478 returns a pointer, the temporary will be a shallow copy and
6479 mustn't be deallocated. */
6480 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6481 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6482 tmp, NULL_TREE, false,
6483 !sym->attr.pointer, callee_alloc,
6484 &se->ss->info->expr->where);
6486 /* Pass the temporary as the first argument. */
6487 result = info->descriptor;
6488 tmp = gfc_build_addr_expr (NULL_TREE, result);
6489 vec_safe_push (retargs, tmp);
6491 else if (ts.type == BT_CHARACTER)
6493 /* Pass the string length. */
6494 type = gfc_get_character_type (ts.kind, ts.u.cl);
6495 type = build_pointer_type (type);
6497 /* Emit a DECL_EXPR for the VLA type. */
6498 tmp = TREE_TYPE (type);
6500 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6502 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6503 DECL_ARTIFICIAL (tmp) = 1;
6504 DECL_IGNORED_P (tmp) = 1;
6505 tmp = fold_build1_loc (input_location, DECL_EXPR,
6506 TREE_TYPE (tmp), tmp);
6507 gfc_add_expr_to_block (&se->pre, tmp);
6510 /* Return an address to a char[0:len-1]* temporary for
6511 character pointers. */
6512 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6513 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6515 var = gfc_create_var (type, "pstr");
6517 if ((!comp && sym->attr.allocatable)
6518 || (comp && comp->attr.allocatable))
6520 gfc_add_modify (&se->pre, var,
6521 fold_convert (TREE_TYPE (var),
6522 null_pointer_node));
6523 tmp = gfc_call_free (var);
6524 gfc_add_expr_to_block (&se->post, tmp);
6527 /* Provide an address expression for the function arguments. */
6528 var = gfc_build_addr_expr (NULL_TREE, var);
6531 var = gfc_conv_string_tmp (se, type, len);
6533 vec_safe_push (retargs, var);
6537 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6539 type = gfc_get_complex_type (ts.kind);
6540 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6541 vec_safe_push (retargs, var);
6544 /* Add the string length to the argument list. */
6545 if (ts.type == BT_CHARACTER && ts.deferred)
6549 tmp = gfc_evaluate_now (len, &se->pre);
6550 TREE_STATIC (tmp) = 1;
6551 gfc_add_modify (&se->pre, tmp,
6552 build_int_cst (TREE_TYPE (tmp), 0));
6553 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6554 vec_safe_push (retargs, tmp);
6556 else if (ts.type == BT_CHARACTER)
6557 vec_safe_push (retargs, len);
6559 gfc_free_interface_mapping (&mapping);
6561 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6562 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6563 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6564 vec_safe_reserve (retargs, arglen);
6566 /* Add the return arguments. */
6567 vec_safe_splice (retargs, arglist);
6569 /* Add the hidden present status for optional+value to the arguments. */
6570 vec_safe_splice (retargs, optionalargs);
6572 /* Add the hidden string length parameters to the arguments. */
6573 vec_safe_splice (retargs, stringargs);
6575 /* We may want to append extra arguments here. This is used e.g. for
6576 calls to libgfortran_matmul_??, which need extra information. */
6577 vec_safe_splice (retargs, append_args);
6581 /* Generate the actual call. */
6582 if (base_object == NULL_TREE)
6583 conv_function_val (se, sym, expr);
6585 conv_base_obj_fcn_val (se, base_object, expr);
6587 /* If there are alternate return labels, function type should be
6588 integer. Can't modify the type in place though, since it can be shared
6589 with other functions. For dummy arguments, the typing is done to
6590 this result, even if it has to be repeated for each call. */
6591 if (has_alternate_specifier
6592 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6594 if (!sym->attr.dummy)
6596 TREE_TYPE (sym->backend_decl)
6597 = build_function_type (integer_type_node,
6598 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6599 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6602 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6605 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6606 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6608 /* Allocatable scalar function results must be freed and nullified
6609 after use. This necessitates the creation of a temporary to
6610 hold the result to prevent duplicate calls. */
6611 if (!byref && sym->ts.type != BT_CHARACTER
6612 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6613 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6615 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6616 gfc_add_modify (&se->pre, tmp, se->expr);
6618 tmp = gfc_call_free (tmp);
6619 gfc_add_expr_to_block (&post, tmp);
6620 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6623 /* If we have a pointer function, but we don't want a pointer, e.g.
6626 where f is pointer valued, we have to dereference the result. */
6627 if (!se->want_pointer && !byref
6628 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6629 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6630 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6632 /* f2c calling conventions require a scalar default real function to
6633 return a double precision result. Convert this back to default
6634 real. We only care about the cases that can happen in Fortran 77.
6636 if (flag_f2c && sym->ts.type == BT_REAL
6637 && sym->ts.kind == gfc_default_real_kind
6638 && !sym->attr.always_explicit)
6639 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6641 /* A pure function may still have side-effects - it may modify its
6643 TREE_SIDE_EFFECTS (se->expr) = 1;
6645 if (!sym->attr.pure)
6646 TREE_SIDE_EFFECTS (se->expr) = 1;
6651 /* Add the function call to the pre chain. There is no expression. */
6652 gfc_add_expr_to_block (&se->pre, se->expr);
6653 se->expr = NULL_TREE;
6655 if (!se->direct_byref)
6657 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6659 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6661 /* Check the data pointer hasn't been modified. This would
6662 happen in a function returning a pointer. */
6663 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6664 tmp = fold_build2_loc (input_location, NE_EXPR,
6667 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6670 se->expr = info->descriptor;
6671 /* Bundle in the string length. */
6672 se->string_length = len;
6674 else if (ts.type == BT_CHARACTER)
6676 /* Dereference for character pointer results. */
6677 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6678 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6679 se->expr = build_fold_indirect_ref_loc (input_location, var);
6683 se->string_length = len;
6687 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6688 se->expr = build_fold_indirect_ref_loc (input_location, var);
6693 /* Associate the rhs class object's meta-data with the result, when the
6694 result is a temporary. */
6695 if (args && args->expr && args->expr->ts.type == BT_CLASS
6696 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6697 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6700 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6702 gfc_init_se (&parmse, NULL);
6703 parmse.data_not_needed = 1;
6704 gfc_conv_expr (&parmse, class_expr);
6705 if (!DECL_LANG_SPECIFIC (result))
6706 gfc_allocate_lang_decl (result);
6707 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6708 gfc_free_expr (class_expr);
6709 gcc_assert (parmse.pre.head == NULL_TREE
6710 && parmse.post.head == NULL_TREE);
6713 /* Follow the function call with the argument post block. */
6716 gfc_add_block_to_block (&se->pre, &post);
6718 /* Transformational functions of derived types with allocatable
6719 components must have the result allocatable components copied when the
6720 argument is actually given. */
6721 arg = expr->value.function.actual;
6722 if (result && arg && expr->rank
6723 && expr->value.function.isym
6724 && expr->value.function.isym->transformational
6726 && arg->expr->ts.type == BT_DERIVED
6727 && arg->expr->ts.u.derived->attr.alloc_comp)
6730 /* Copy the allocatable components. We have to use a
6731 temporary here to prevent source allocatable components
6732 from being corrupted. */
6733 tmp2 = gfc_evaluate_now (result, &se->pre);
6734 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6735 result, tmp2, expr->rank, 0);
6736 gfc_add_expr_to_block (&se->pre, tmp);
6737 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6739 gfc_add_expr_to_block (&se->pre, tmp);
6741 /* Finally free the temporary's data field. */
6742 tmp = gfc_conv_descriptor_data_get (tmp2);
6743 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6744 NULL_TREE, NULL_TREE, true,
6745 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6746 gfc_add_expr_to_block (&se->pre, tmp);
6751 /* For a function with a class array result, save the result as
6752 a temporary, set the info fields needed by the scalarizer and
6753 call the finalization function of the temporary. Note that the
6754 nullification of allocatable components needed by the result
6755 is done in gfc_trans_assignment_1. */
6756 if (expr && ((gfc_is_class_array_function (expr)
6757 && se->ss && se->ss->loop)
6758 || gfc_is_alloc_class_scalar_function (expr))
6759 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6760 && expr->must_finalize)
6765 if (se->ss && se->ss->loop)
6767 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6768 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6769 tmp = gfc_class_data_get (se->expr);
6770 info->descriptor = tmp;
6771 info->data = gfc_conv_descriptor_data_get (tmp);
6772 info->offset = gfc_conv_descriptor_offset_get (tmp);
6773 for (n = 0; n < se->ss->loop->dimen; n++)
6775 tree dim = gfc_rank_cst[n];
6776 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6777 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6782 /* TODO Eliminate the doubling of temporaries. This
6783 one is necessary to ensure no memory leakage. */
6784 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6785 tmp = gfc_class_data_get (se->expr);
6786 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6787 CLASS_DATA (expr->value.function.esym->result)->attr);
6790 if ((gfc_is_class_array_function (expr)
6791 || gfc_is_alloc_class_scalar_function (expr))
6792 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6793 goto no_finalization;
6795 final_fndecl = gfc_class_vtab_final_get (se->expr);
6796 is_final = fold_build2_loc (input_location, NE_EXPR,
6799 fold_convert (TREE_TYPE (final_fndecl),
6800 null_pointer_node));
6801 final_fndecl = build_fold_indirect_ref_loc (input_location,
6803 tmp = build_call_expr_loc (input_location,
6805 gfc_build_addr_expr (NULL, tmp),
6806 gfc_class_vtab_size_get (se->expr),
6807 boolean_false_node);
6808 tmp = fold_build3_loc (input_location, COND_EXPR,
6809 void_type_node, is_final, tmp,
6810 build_empty_stmt (input_location));
6812 if (se->ss && se->ss->loop)
6814 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6815 tmp = fold_build2_loc (input_location, NE_EXPR,
6818 fold_convert (TREE_TYPE (info->data),
6819 null_pointer_node));
6820 tmp = fold_build3_loc (input_location, COND_EXPR,
6821 void_type_node, tmp,
6822 gfc_call_free (info->data),
6823 build_empty_stmt (input_location));
6824 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6829 gfc_prepend_expr_to_block (&se->post, tmp);
6830 classdata = gfc_class_data_get (se->expr);
6831 tmp = fold_build2_loc (input_location, NE_EXPR,
6834 fold_convert (TREE_TYPE (classdata),
6835 null_pointer_node));
6836 tmp = fold_build3_loc (input_location, COND_EXPR,
6837 void_type_node, tmp,
6838 gfc_call_free (classdata),
6839 build_empty_stmt (input_location));
6840 gfc_add_expr_to_block (&se->post, tmp);
6845 gfc_add_block_to_block (&se->post, &post);
6848 return has_alternate_specifier;
6852 /* Fill a character string with spaces. */
6855 fill_with_spaces (tree start, tree type, tree size)
6857 stmtblock_t block, loop;
6858 tree i, el, exit_label, cond, tmp;
6860 /* For a simple char type, we can call memset(). */
6861 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6862 return build_call_expr_loc (input_location,
6863 builtin_decl_explicit (BUILT_IN_MEMSET),
6865 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6866 lang_hooks.to_target_charset (' ')),
6867 fold_convert (size_type_node, size));
6869 /* Otherwise, we use a loop:
6870 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6874 /* Initialize variables. */
6875 gfc_init_block (&block);
6876 i = gfc_create_var (sizetype, "i");
6877 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6878 el = gfc_create_var (build_pointer_type (type), "el");
6879 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6880 exit_label = gfc_build_label_decl (NULL_TREE);
6881 TREE_USED (exit_label) = 1;
6885 gfc_init_block (&loop);
6887 /* Exit condition. */
6888 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6889 build_zero_cst (sizetype));
6890 tmp = build1_v (GOTO_EXPR, exit_label);
6891 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6892 build_empty_stmt (input_location));
6893 gfc_add_expr_to_block (&loop, tmp);
6896 gfc_add_modify (&loop,
6897 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6898 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6900 /* Increment loop variables. */
6901 gfc_add_modify (&loop, i,
6902 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6903 TYPE_SIZE_UNIT (type)));
6904 gfc_add_modify (&loop, el,
6905 fold_build_pointer_plus_loc (input_location,
6906 el, TYPE_SIZE_UNIT (type)));
6908 /* Making the loop... actually loop! */
6909 tmp = gfc_finish_block (&loop);
6910 tmp = build1_v (LOOP_EXPR, tmp);
6911 gfc_add_expr_to_block (&block, tmp);
6913 /* The exit label. */
6914 tmp = build1_v (LABEL_EXPR, exit_label);
6915 gfc_add_expr_to_block (&block, tmp);
6918 return gfc_finish_block (&block);
6922 /* Generate code to copy a string. */
6925 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6926 int dkind, tree slength, tree src, int skind)
6928 tree tmp, dlen, slen;
6937 stmtblock_t tempblock;
6939 gcc_assert (dkind == skind);
6941 if (slength != NULL_TREE)
6943 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6944 ssc = gfc_string_to_single_character (slen, src, skind);
6948 slen = build_one_cst (gfc_charlen_type_node);
6952 if (dlength != NULL_TREE)
6954 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6955 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6959 dlen = build_one_cst (gfc_charlen_type_node);
6963 /* Assign directly if the types are compatible. */
6964 if (dsc != NULL_TREE && ssc != NULL_TREE
6965 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6967 gfc_add_modify (block, dsc, ssc);
6971 /* The string copy algorithm below generates code like
6975 if (srclen < destlen)
6977 memmove (dest, src, srclen);
6979 memset (&dest[srclen], ' ', destlen - srclen);
6983 // Truncate if too long.
6984 memmove (dest, src, destlen);
6989 /* Do nothing if the destination length is zero. */
6990 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6991 build_zero_cst (TREE_TYPE (dlen)));
6993 /* For non-default character kinds, we have to multiply the string
6994 length by the base type size. */
6995 chartype = gfc_get_char_type (dkind);
6996 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6998 fold_convert (TREE_TYPE (slen),
6999 TYPE_SIZE_UNIT (chartype)));
7000 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7002 fold_convert (TREE_TYPE (dlen),
7003 TYPE_SIZE_UNIT (chartype)));
7005 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7006 dest = fold_convert (pvoid_type_node, dest);
7008 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7010 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7011 src = fold_convert (pvoid_type_node, src);
7013 src = gfc_build_addr_expr (pvoid_type_node, src);
7015 /* Truncate string if source is too long. */
7016 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7019 /* Copy and pad with spaces. */
7020 tmp3 = build_call_expr_loc (input_location,
7021 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7023 fold_convert (size_type_node, slen));
7025 /* Wstringop-overflow appears at -O3 even though this warning is not
7026 explicitly available in fortran nor can it be switched off. If the
7027 source length is a constant, its negative appears as a very large
7028 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7029 the result of the MINUS_EXPR suppresses this spurious warning. */
7030 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7031 TREE_TYPE(dlen), dlen, slen);
7032 if (slength && TREE_CONSTANT (slength))
7033 tmp = gfc_evaluate_now (tmp, block);
7035 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7036 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7038 gfc_init_block (&tempblock);
7039 gfc_add_expr_to_block (&tempblock, tmp3);
7040 gfc_add_expr_to_block (&tempblock, tmp4);
7041 tmp3 = gfc_finish_block (&tempblock);
7043 /* The truncated memmove if the slen >= dlen. */
7044 tmp2 = build_call_expr_loc (input_location,
7045 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7047 fold_convert (size_type_node, dlen));
7049 /* The whole copy_string function is there. */
7050 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7052 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7053 build_empty_stmt (input_location));
7054 gfc_add_expr_to_block (block, tmp);
7058 /* Translate a statement function.
7059 The value of a statement function reference is obtained by evaluating the
7060 expression using the values of the actual arguments for the values of the
7061 corresponding dummy arguments. */
7064 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7068 gfc_formal_arglist *fargs;
7069 gfc_actual_arglist *args;
7072 gfc_saved_var *saved_vars;
7078 sym = expr->symtree->n.sym;
7079 args = expr->value.function.actual;
7080 gfc_init_se (&lse, NULL);
7081 gfc_init_se (&rse, NULL);
7084 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7086 saved_vars = XCNEWVEC (gfc_saved_var, n);
7087 temp_vars = XCNEWVEC (tree, n);
7089 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7090 fargs = fargs->next, n++)
7092 /* Each dummy shall be specified, explicitly or implicitly, to be
7094 gcc_assert (fargs->sym->attr.dimension == 0);
7097 if (fsym->ts.type == BT_CHARACTER)
7099 /* Copy string arguments. */
7102 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7103 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7105 /* Create a temporary to hold the value. */
7106 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7107 fsym->ts.u.cl->backend_decl
7108 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7110 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7111 temp_vars[n] = gfc_create_var (type, fsym->name);
7113 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7115 gfc_conv_expr (&rse, args->expr);
7116 gfc_conv_string_parameter (&rse);
7117 gfc_add_block_to_block (&se->pre, &lse.pre);
7118 gfc_add_block_to_block (&se->pre, &rse.pre);
7120 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7121 rse.string_length, rse.expr, fsym->ts.kind);
7122 gfc_add_block_to_block (&se->pre, &lse.post);
7123 gfc_add_block_to_block (&se->pre, &rse.post);
7127 /* For everything else, just evaluate the expression. */
7129 /* Create a temporary to hold the value. */
7130 type = gfc_typenode_for_spec (&fsym->ts);
7131 temp_vars[n] = gfc_create_var (type, fsym->name);
7133 gfc_conv_expr (&lse, args->expr);
7135 gfc_add_block_to_block (&se->pre, &lse.pre);
7136 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7137 gfc_add_block_to_block (&se->pre, &lse.post);
7143 /* Use the temporary variables in place of the real ones. */
7144 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7145 fargs = fargs->next, n++)
7146 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7148 gfc_conv_expr (se, sym->value);
7150 if (sym->ts.type == BT_CHARACTER)
7152 gfc_conv_const_charlen (sym->ts.u.cl);
7154 /* Force the expression to the correct length. */
7155 if (!INTEGER_CST_P (se->string_length)
7156 || tree_int_cst_lt (se->string_length,
7157 sym->ts.u.cl->backend_decl))
7159 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7160 tmp = gfc_create_var (type, sym->name);
7161 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7162 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7163 sym->ts.kind, se->string_length, se->expr,
7167 se->string_length = sym->ts.u.cl->backend_decl;
7170 /* Restore the original variables. */
7171 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7172 fargs = fargs->next, n++)
7173 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7179 /* Translate a function expression. */
7182 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7186 if (expr->value.function.isym)
7188 gfc_conv_intrinsic_function (se, expr);
7192 /* expr.value.function.esym is the resolved (specific) function symbol for
7193 most functions. However this isn't set for dummy procedures. */
7194 sym = expr->value.function.esym;
7196 sym = expr->symtree->n.sym;
7198 /* The IEEE_ARITHMETIC functions are caught here. */
7199 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7200 if (gfc_conv_ieee_arithmetic_function (se, expr))
7203 /* We distinguish statement functions from general functions to improve
7204 runtime performance. */
7205 if (sym->attr.proc == PROC_ST_FUNCTION)
7207 gfc_conv_statement_function (se, expr);
7211 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7216 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7219 is_zero_initializer_p (gfc_expr * expr)
7221 if (expr->expr_type != EXPR_CONSTANT)
7224 /* We ignore constants with prescribed memory representations for now. */
7225 if (expr->representation.string)
7228 switch (expr->ts.type)
7231 return mpz_cmp_si (expr->value.integer, 0) == 0;
7234 return mpfr_zero_p (expr->value.real)
7235 && MPFR_SIGN (expr->value.real) >= 0;
7238 return expr->value.logical == 0;
7241 return mpfr_zero_p (mpc_realref (expr->value.complex))
7242 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7243 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7244 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7254 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7259 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7260 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7262 gfc_conv_tmp_array_ref (se);
7266 /* Build a static initializer. EXPR is the expression for the initial value.
7267 The other parameters describe the variable of the component being
7268 initialized. EXPR may be null. */
7271 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7272 bool array, bool pointer, bool procptr)
7276 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7277 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7278 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7279 return build_constructor (type, NULL);
7281 if (!(expr || pointer || procptr))
7284 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7285 (these are the only two iso_c_binding derived types that can be
7286 used as initialization expressions). If so, we need to modify
7287 the 'expr' to be that for a (void *). */
7288 if (expr != NULL && expr->ts.type == BT_DERIVED
7289 && expr->ts.is_iso_c && expr->ts.u.derived)
7291 if (TREE_CODE (type) == ARRAY_TYPE)
7292 return build_constructor (type, NULL);
7293 else if (POINTER_TYPE_P (type))
7294 return build_int_cst (type, 0);
7299 if (array && !procptr)
7302 /* Arrays need special handling. */
7304 ctor = gfc_build_null_descriptor (type);
7305 /* Special case assigning an array to zero. */
7306 else if (is_zero_initializer_p (expr))
7307 ctor = build_constructor (type, NULL);
7309 ctor = gfc_conv_array_initializer (type, expr);
7310 TREE_STATIC (ctor) = 1;
7313 else if (pointer || procptr)
7315 if (ts->type == BT_CLASS && !procptr)
7317 gfc_init_se (&se, NULL);
7318 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7319 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7320 TREE_STATIC (se.expr) = 1;
7323 else if (!expr || expr->expr_type == EXPR_NULL)
7324 return fold_convert (type, null_pointer_node);
7327 gfc_init_se (&se, NULL);
7328 se.want_pointer = 1;
7329 gfc_conv_expr (&se, expr);
7330 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7340 gfc_init_se (&se, NULL);
7341 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7342 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7344 gfc_conv_structure (&se, expr, 1);
7345 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7346 TREE_STATIC (se.expr) = 1;
7351 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7352 TREE_STATIC (ctor) = 1;
7357 gfc_init_se (&se, NULL);
7358 gfc_conv_constant (&se, expr);
7359 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7366 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7372 gfc_array_info *lss_array;
7379 gfc_start_block (&block);
7381 /* Initialize the scalarizer. */
7382 gfc_init_loopinfo (&loop);
7384 gfc_init_se (&lse, NULL);
7385 gfc_init_se (&rse, NULL);
7388 rss = gfc_walk_expr (expr);
7389 if (rss == gfc_ss_terminator)
7390 /* The rhs is scalar. Add a ss for the expression. */
7391 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7393 /* Create a SS for the destination. */
7394 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7396 lss_array = &lss->info->data.array;
7397 lss_array->shape = gfc_get_shape (cm->as->rank);
7398 lss_array->descriptor = dest;
7399 lss_array->data = gfc_conv_array_data (dest);
7400 lss_array->offset = gfc_conv_array_offset (dest);
7401 for (n = 0; n < cm->as->rank; n++)
7403 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7404 lss_array->stride[n] = gfc_index_one_node;
7406 mpz_init (lss_array->shape[n]);
7407 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7408 cm->as->lower[n]->value.integer);
7409 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7412 /* Associate the SS with the loop. */
7413 gfc_add_ss_to_loop (&loop, lss);
7414 gfc_add_ss_to_loop (&loop, rss);
7416 /* Calculate the bounds of the scalarization. */
7417 gfc_conv_ss_startstride (&loop);
7419 /* Setup the scalarizing loops. */
7420 gfc_conv_loop_setup (&loop, &expr->where);
7422 /* Setup the gfc_se structures. */
7423 gfc_copy_loopinfo_to_se (&lse, &loop);
7424 gfc_copy_loopinfo_to_se (&rse, &loop);
7427 gfc_mark_ss_chain_used (rss, 1);
7429 gfc_mark_ss_chain_used (lss, 1);
7431 /* Start the scalarized loop body. */
7432 gfc_start_scalarized_body (&loop, &body);
7434 gfc_conv_tmp_array_ref (&lse);
7435 if (cm->ts.type == BT_CHARACTER)
7436 lse.string_length = cm->ts.u.cl->backend_decl;
7438 gfc_conv_expr (&rse, expr);
7440 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7441 gfc_add_expr_to_block (&body, tmp);
7443 gcc_assert (rse.ss == gfc_ss_terminator);
7445 /* Generate the copying loops. */
7446 gfc_trans_scalarizing_loops (&loop, &body);
7448 /* Wrap the whole thing up. */
7449 gfc_add_block_to_block (&block, &loop.pre);
7450 gfc_add_block_to_block (&block, &loop.post);
7452 gcc_assert (lss_array->shape != NULL);
7453 gfc_free_shape (&lss_array->shape, cm->as->rank);
7454 gfc_cleanup_loop (&loop);
7456 return gfc_finish_block (&block);
7461 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7471 gfc_expr *arg = NULL;
7473 gfc_start_block (&block);
7474 gfc_init_se (&se, NULL);
7476 /* Get the descriptor for the expressions. */
7477 se.want_pointer = 0;
7478 gfc_conv_expr_descriptor (&se, expr);
7479 gfc_add_block_to_block (&block, &se.pre);
7480 gfc_add_modify (&block, dest, se.expr);
7482 /* Deal with arrays of derived types with allocatable components. */
7483 if (gfc_bt_struct (cm->ts.type)
7484 && cm->ts.u.derived->attr.alloc_comp)
7485 // TODO: Fix caf_mode
7486 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7489 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7490 && CLASS_DATA(cm)->attr.allocatable)
7492 if (cm->ts.u.derived->attr.alloc_comp)
7493 // TODO: Fix caf_mode
7494 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7499 tmp = TREE_TYPE (dest);
7500 tmp = gfc_duplicate_allocatable (dest, se.expr,
7501 tmp, expr->rank, NULL_TREE);
7505 tmp = gfc_duplicate_allocatable (dest, se.expr,
7506 TREE_TYPE(cm->backend_decl),
7507 cm->as->rank, NULL_TREE);
7509 gfc_add_expr_to_block (&block, tmp);
7510 gfc_add_block_to_block (&block, &se.post);
7512 if (expr->expr_type != EXPR_VARIABLE)
7513 gfc_conv_descriptor_data_set (&block, se.expr,
7516 /* We need to know if the argument of a conversion function is a
7517 variable, so that the correct lower bound can be used. */
7518 if (expr->expr_type == EXPR_FUNCTION
7519 && expr->value.function.isym
7520 && expr->value.function.isym->conversion
7521 && expr->value.function.actual->expr
7522 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7523 arg = expr->value.function.actual->expr;
7525 /* Obtain the array spec of full array references. */
7527 as = gfc_get_full_arrayspec_from_expr (arg);
7529 as = gfc_get_full_arrayspec_from_expr (expr);
7531 /* Shift the lbound and ubound of temporaries to being unity,
7532 rather than zero, based. Always calculate the offset. */
7533 offset = gfc_conv_descriptor_offset_get (dest);
7534 gfc_add_modify (&block, offset, gfc_index_zero_node);
7535 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7537 for (n = 0; n < expr->rank; n++)
7542 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7543 TODO It looks as if gfc_conv_expr_descriptor should return
7544 the correct bounds and that the following should not be
7545 necessary. This would simplify gfc_conv_intrinsic_bound
7547 if (as && as->lower[n])
7550 gfc_init_se (&lbse, NULL);
7551 gfc_conv_expr (&lbse, as->lower[n]);
7552 gfc_add_block_to_block (&block, &lbse.pre);
7553 lbound = gfc_evaluate_now (lbse.expr, &block);
7557 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7558 lbound = gfc_conv_descriptor_lbound_get (tmp,
7562 lbound = gfc_conv_descriptor_lbound_get (dest,
7565 lbound = gfc_index_one_node;
7567 lbound = fold_convert (gfc_array_index_type, lbound);
7569 /* Shift the bounds and set the offset accordingly. */
7570 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7571 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7572 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7573 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7575 gfc_conv_descriptor_ubound_set (&block, dest,
7576 gfc_rank_cst[n], tmp);
7577 gfc_conv_descriptor_lbound_set (&block, dest,
7578 gfc_rank_cst[n], lbound);
7580 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7581 gfc_conv_descriptor_lbound_get (dest,
7583 gfc_conv_descriptor_stride_get (dest,
7585 gfc_add_modify (&block, tmp2, tmp);
7586 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7588 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7593 /* If a conversion expression has a null data pointer
7594 argument, nullify the allocatable component. */
7598 if (arg->symtree->n.sym->attr.allocatable
7599 || arg->symtree->n.sym->attr.pointer)
7601 non_null_expr = gfc_finish_block (&block);
7602 gfc_start_block (&block);
7603 gfc_conv_descriptor_data_set (&block, dest,
7605 null_expr = gfc_finish_block (&block);
7606 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7607 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7608 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7609 return build3_v (COND_EXPR, tmp,
7610 null_expr, non_null_expr);
7614 return gfc_finish_block (&block);
7618 /* Allocate or reallocate scalar component, as necessary. */
7621 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7631 tree lhs_cl_size = NULL_TREE;
7636 if (!expr2 || expr2->rank)
7639 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7641 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7643 char name[GFC_MAX_SYMBOL_LEN+9];
7644 gfc_component *strlen;
7645 /* Use the rhs string length and the lhs element size. */
7646 gcc_assert (expr2->ts.type == BT_CHARACTER);
7647 if (!expr2->ts.u.cl->backend_decl)
7649 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7650 gcc_assert (expr2->ts.u.cl->backend_decl);
7653 size = expr2->ts.u.cl->backend_decl;
7655 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7657 sprintf (name, "_%s_length", cm->name);
7658 strlen = gfc_find_component (sym, name, true, true, NULL);
7659 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7660 gfc_charlen_type_node,
7661 TREE_OPERAND (comp, 0),
7662 strlen->backend_decl, NULL_TREE);
7664 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7665 tmp = TYPE_SIZE_UNIT (tmp);
7666 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7667 TREE_TYPE (tmp), tmp,
7668 fold_convert (TREE_TYPE (tmp), size));
7670 else if (cm->ts.type == BT_CLASS)
7672 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7673 if (expr2->ts.type == BT_DERIVED)
7675 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7676 size = TYPE_SIZE_UNIT (tmp);
7682 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7683 gfc_add_vptr_component (e2vtab);
7684 gfc_add_size_component (e2vtab);
7685 gfc_init_se (&se, NULL);
7686 gfc_conv_expr (&se, e2vtab);
7687 gfc_add_block_to_block (block, &se.pre);
7688 size = fold_convert (size_type_node, se.expr);
7689 gfc_free_expr (e2vtab);
7691 size_in_bytes = size;
7695 /* Otherwise use the length in bytes of the rhs. */
7696 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7697 size_in_bytes = size;
7700 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7701 size_in_bytes, size_one_node);
7703 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7705 tmp = build_call_expr_loc (input_location,
7706 builtin_decl_explicit (BUILT_IN_CALLOC),
7707 2, build_one_cst (size_type_node),
7709 tmp = fold_convert (TREE_TYPE (comp), tmp);
7710 gfc_add_modify (block, comp, tmp);
7714 tmp = build_call_expr_loc (input_location,
7715 builtin_decl_explicit (BUILT_IN_MALLOC),
7717 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7718 ptr = gfc_class_data_get (comp);
7721 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7722 gfc_add_modify (block, ptr, tmp);
7725 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7726 /* Update the lhs character length. */
7727 gfc_add_modify (block, lhs_cl_size,
7728 fold_convert (TREE_TYPE (lhs_cl_size), size));
7732 /* Assign a single component of a derived type constructor. */
7735 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7736 gfc_symbol *sym, bool init)
7744 gfc_start_block (&block);
7746 if (cm->attr.pointer || cm->attr.proc_pointer)
7748 /* Only care about pointers here, not about allocatables. */
7749 gfc_init_se (&se, NULL);
7750 /* Pointer component. */
7751 if ((cm->attr.dimension || cm->attr.codimension)
7752 && !cm->attr.proc_pointer)
7754 /* Array pointer. */
7755 if (expr->expr_type == EXPR_NULL)
7756 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7759 se.direct_byref = 1;
7761 gfc_conv_expr_descriptor (&se, expr);
7762 gfc_add_block_to_block (&block, &se.pre);
7763 gfc_add_block_to_block (&block, &se.post);
7768 /* Scalar pointers. */
7769 se.want_pointer = 1;
7770 gfc_conv_expr (&se, expr);
7771 gfc_add_block_to_block (&block, &se.pre);
7773 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7774 && expr->symtree->n.sym->attr.dummy)
7775 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7777 gfc_add_modify (&block, dest,
7778 fold_convert (TREE_TYPE (dest), se.expr));
7779 gfc_add_block_to_block (&block, &se.post);
7782 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7784 /* NULL initialization for CLASS components. */
7785 tmp = gfc_trans_structure_assign (dest,
7786 gfc_class_initializer (&cm->ts, expr),
7788 gfc_add_expr_to_block (&block, tmp);
7790 else if ((cm->attr.dimension || cm->attr.codimension)
7791 && !cm->attr.proc_pointer)
7793 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7794 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7795 else if (cm->attr.allocatable || cm->attr.pdt_array)
7797 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7798 gfc_add_expr_to_block (&block, tmp);
7802 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7803 gfc_add_expr_to_block (&block, tmp);
7806 else if (cm->ts.type == BT_CLASS
7807 && CLASS_DATA (cm)->attr.dimension
7808 && CLASS_DATA (cm)->attr.allocatable
7809 && expr->ts.type == BT_DERIVED)
7811 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7812 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7813 tmp = gfc_class_vptr_get (dest);
7814 gfc_add_modify (&block, tmp,
7815 fold_convert (TREE_TYPE (tmp), vtab));
7816 tmp = gfc_class_data_get (dest);
7817 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7818 gfc_add_expr_to_block (&block, tmp);
7820 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7822 /* NULL initialization for allocatable components. */
7823 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7824 null_pointer_node));
7826 else if (init && (cm->attr.allocatable
7827 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7828 && expr->ts.type != BT_CLASS)))
7830 /* Take care about non-array allocatable components here. The alloc_*
7831 routine below is motivated by the alloc_scalar_allocatable_for_
7832 assignment() routine, but with the realloc portions removed and
7834 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7839 /* The remainder of these instructions follow the if (cm->attr.pointer)
7840 if (!cm->attr.dimension) part above. */
7841 gfc_init_se (&se, NULL);
7842 gfc_conv_expr (&se, expr);
7843 gfc_add_block_to_block (&block, &se.pre);
7845 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7846 && expr->symtree->n.sym->attr.dummy)
7847 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7849 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7851 tmp = gfc_class_data_get (dest);
7852 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7853 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7854 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7855 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7856 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7859 tmp = build_fold_indirect_ref_loc (input_location, dest);
7861 /* For deferred strings insert a memcpy. */
7862 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7865 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7866 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7868 : expr->ts.u.cl->backend_decl);
7869 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7870 gfc_add_expr_to_block (&block, tmp);
7873 gfc_add_modify (&block, tmp,
7874 fold_convert (TREE_TYPE (tmp), se.expr));
7875 gfc_add_block_to_block (&block, &se.post);
7877 else if (expr->ts.type == BT_UNION)
7880 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7881 /* We mark that the entire union should be initialized with a contrived
7882 EXPR_NULL expression at the beginning. */
7883 if (c != NULL && c->n.component == NULL
7884 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7886 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7887 dest, build_constructor (TREE_TYPE (dest), NULL));
7888 gfc_add_expr_to_block (&block, tmp);
7889 c = gfc_constructor_next (c);
7891 /* The following constructor expression, if any, represents a specific
7892 map intializer, as given by the user. */
7893 if (c != NULL && c->expr != NULL)
7895 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7896 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7897 gfc_add_expr_to_block (&block, tmp);
7900 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7902 if (expr->expr_type != EXPR_STRUCTURE)
7904 tree dealloc = NULL_TREE;
7905 gfc_init_se (&se, NULL);
7906 gfc_conv_expr (&se, expr);
7907 gfc_add_block_to_block (&block, &se.pre);
7908 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7909 expression in a temporary variable and deallocate the allocatable
7910 components. Then we can the copy the expression to the result. */
7911 if (cm->ts.u.derived->attr.alloc_comp
7912 && expr->expr_type != EXPR_VARIABLE)
7914 se.expr = gfc_evaluate_now (se.expr, &block);
7915 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7918 gfc_add_modify (&block, dest,
7919 fold_convert (TREE_TYPE (dest), se.expr));
7920 if (cm->ts.u.derived->attr.alloc_comp
7921 && expr->expr_type != EXPR_NULL)
7923 // TODO: Fix caf_mode
7924 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7925 dest, expr->rank, 0);
7926 gfc_add_expr_to_block (&block, tmp);
7927 if (dealloc != NULL_TREE)
7928 gfc_add_expr_to_block (&block, dealloc);
7930 gfc_add_block_to_block (&block, &se.post);
7934 /* Nested constructors. */
7935 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7936 gfc_add_expr_to_block (&block, tmp);
7939 else if (gfc_deferred_strlen (cm, &tmp))
7943 gcc_assert (strlen);
7944 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7946 TREE_OPERAND (dest, 0),
7949 if (expr->expr_type == EXPR_NULL)
7951 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7952 gfc_add_modify (&block, dest, tmp);
7953 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7954 gfc_add_modify (&block, strlen, tmp);
7959 gfc_init_se (&se, NULL);
7960 gfc_conv_expr (&se, expr);
7961 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7962 tmp = build_call_expr_loc (input_location,
7963 builtin_decl_explicit (BUILT_IN_MALLOC),
7965 gfc_add_modify (&block, dest,
7966 fold_convert (TREE_TYPE (dest), tmp));
7967 gfc_add_modify (&block, strlen,
7968 fold_convert (TREE_TYPE (strlen), se.string_length));
7969 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7970 gfc_add_expr_to_block (&block, tmp);
7973 else if (!cm->attr.artificial)
7975 /* Scalar component (excluding deferred parameters). */
7976 gfc_init_se (&se, NULL);
7977 gfc_init_se (&lse, NULL);
7979 gfc_conv_expr (&se, expr);
7980 if (cm->ts.type == BT_CHARACTER)
7981 lse.string_length = cm->ts.u.cl->backend_decl;
7983 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7984 gfc_add_expr_to_block (&block, tmp);
7986 return gfc_finish_block (&block);
7989 /* Assign a derived type constructor to a variable. */
7992 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8001 gfc_start_block (&block);
8002 cm = expr->ts.u.derived->components;
8004 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8005 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8006 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8010 gfc_init_se (&se, NULL);
8011 gfc_init_se (&lse, NULL);
8012 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8014 gfc_add_modify (&block, lse.expr,
8015 fold_convert (TREE_TYPE (lse.expr), se.expr));
8017 return gfc_finish_block (&block);
8021 gfc_init_se (&se, NULL);
8023 for (c = gfc_constructor_first (expr->value.constructor);
8024 c; c = gfc_constructor_next (c), cm = cm->next)
8026 /* Skip absent members in default initializers. */
8027 if (!c->expr && !cm->attr.allocatable)
8030 /* Register the component with the caf-lib before it is initialized.
8031 Register only allocatable components, that are not coarray'ed
8032 components (%comp[*]). Only register when the constructor is not the
8034 if (coarray && !cm->attr.codimension
8035 && (cm->attr.allocatable || cm->attr.pointer)
8036 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8038 tree token, desc, size;
8039 bool is_array = cm->ts.type == BT_CLASS
8040 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8042 field = cm->backend_decl;
8043 field = fold_build3_loc (input_location, COMPONENT_REF,
8044 TREE_TYPE (field), dest, field, NULL_TREE);
8045 if (cm->ts.type == BT_CLASS)
8046 field = gfc_class_data_get (field);
8048 token = is_array ? gfc_conv_descriptor_token (field)
8049 : fold_build3_loc (input_location, COMPONENT_REF,
8050 TREE_TYPE (cm->caf_token), dest,
8051 cm->caf_token, NULL_TREE);
8055 /* The _caf_register routine looks at the rank of the array
8056 descriptor to decide whether the data registered is an array
8058 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8060 /* When the rank is not known just set a positive rank, which
8061 suffices to recognize the data as array. */
8064 size = build_zero_cst (size_type_node);
8066 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8067 build_int_cst (signed_char_type_node, rank));
8071 desc = gfc_conv_scalar_to_descriptor (&se, field,
8072 cm->ts.type == BT_CLASS
8073 ? CLASS_DATA (cm)->attr
8075 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8077 gfc_add_block_to_block (&block, &se.pre);
8078 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8079 7, size, build_int_cst (
8081 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8082 gfc_build_addr_expr (pvoid_type_node,
8084 gfc_build_addr_expr (NULL_TREE, desc),
8085 null_pointer_node, null_pointer_node,
8087 gfc_add_expr_to_block (&block, tmp);
8089 field = cm->backend_decl;
8090 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8091 dest, field, NULL_TREE);
8094 gfc_expr *e = gfc_get_null_expr (NULL);
8095 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8100 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8101 expr->ts.u.derived, init);
8102 gfc_add_expr_to_block (&block, tmp);
8104 return gfc_finish_block (&block);
8108 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8109 gfc_component *un, gfc_expr *init)
8111 gfc_constructor *ctor;
8113 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8116 ctor = gfc_constructor_first (init->value.constructor);
8118 if (ctor == NULL || ctor->expr == NULL)
8121 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8123 /* If we have an 'initialize all' constructor, do it first. */
8124 if (ctor->expr->expr_type == EXPR_NULL)
8126 tree union_type = TREE_TYPE (un->backend_decl);
8127 tree val = build_constructor (union_type, NULL);
8128 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8129 ctor = gfc_constructor_next (ctor);
8132 /* Add the map initializer on top. */
8133 if (ctor != NULL && ctor->expr != NULL)
8135 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8136 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8137 TREE_TYPE (un->backend_decl),
8138 un->attr.dimension, un->attr.pointer,
8139 un->attr.proc_pointer);
8140 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8144 /* Build an expression for a constructor. If init is nonzero then
8145 this is part of a static variable initializer. */
8148 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8155 vec<constructor_elt, va_gc> *v = NULL;
8157 gcc_assert (se->ss == NULL);
8158 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8159 type = gfc_typenode_for_spec (&expr->ts);
8163 /* Create a temporary variable and fill it in. */
8164 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8165 /* The symtree in expr is NULL, if the code to generate is for
8166 initializing the static members only. */
8167 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8169 gfc_add_expr_to_block (&se->pre, tmp);
8173 cm = expr->ts.u.derived->components;
8175 for (c = gfc_constructor_first (expr->value.constructor);
8176 c; c = gfc_constructor_next (c), cm = cm->next)
8178 /* Skip absent members in default initializers and allocatable
8179 components. Although the latter have a default initializer
8180 of EXPR_NULL,... by default, the static nullify is not needed
8181 since this is done every time we come into scope. */
8182 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8185 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8186 && strcmp (cm->name, "_extends") == 0
8187 && cm->initializer->symtree)
8191 vtabs = cm->initializer->symtree->n.sym;
8192 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8193 vtab = unshare_expr_without_location (vtab);
8194 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8196 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8198 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8199 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8200 fold_convert (TREE_TYPE (cm->backend_decl),
8203 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8204 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8205 fold_convert (TREE_TYPE (cm->backend_decl),
8206 integer_zero_node));
8207 else if (cm->ts.type == BT_UNION)
8208 gfc_conv_union_initializer (v, cm, c->expr);
8211 val = gfc_conv_initializer (c->expr, &cm->ts,
8212 TREE_TYPE (cm->backend_decl),
8213 cm->attr.dimension, cm->attr.pointer,
8214 cm->attr.proc_pointer);
8215 val = unshare_expr_without_location (val);
8217 /* Append it to the constructor list. */
8218 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8222 se->expr = build_constructor (type, v);
8224 TREE_CONSTANT (se->expr) = 1;
8228 /* Translate a substring expression. */
8231 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8237 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8239 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8240 expr->value.character.length,
8241 expr->value.character.string);
8243 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8244 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8247 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8251 /* Entry point for expression translation. Evaluates a scalar quantity.
8252 EXPR is the expression to be translated, and SE is the state structure if
8253 called from within the scalarized. */
8256 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8261 if (ss && ss->info->expr == expr
8262 && (ss->info->type == GFC_SS_SCALAR
8263 || ss->info->type == GFC_SS_REFERENCE))
8265 gfc_ss_info *ss_info;
8268 /* Substitute a scalar expression evaluated outside the scalarization
8270 se->expr = ss_info->data.scalar.value;
8271 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8272 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8274 se->string_length = ss_info->string_length;
8275 gfc_advance_se_ss_chain (se);
8279 /* We need to convert the expressions for the iso_c_binding derived types.
8280 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8281 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8282 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8283 updated to be an integer with a kind equal to the size of a (void *). */
8284 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8285 && expr->ts.u.derived->attr.is_bind_c)
8287 if (expr->expr_type == EXPR_VARIABLE
8288 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8289 || expr->symtree->n.sym->intmod_sym_id
8290 == ISOCBINDING_NULL_FUNPTR))
8292 /* Set expr_type to EXPR_NULL, which will result in
8293 null_pointer_node being used below. */
8294 expr->expr_type = EXPR_NULL;
8298 /* Update the type/kind of the expression to be what the new
8299 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8300 expr->ts.type = BT_INTEGER;
8301 expr->ts.f90_type = BT_VOID;
8302 expr->ts.kind = gfc_index_integer_kind;
8306 gfc_fix_class_refs (expr);
8308 switch (expr->expr_type)
8311 gfc_conv_expr_op (se, expr);
8315 gfc_conv_function_expr (se, expr);
8319 gfc_conv_constant (se, expr);
8323 gfc_conv_variable (se, expr);
8327 se->expr = null_pointer_node;
8330 case EXPR_SUBSTRING:
8331 gfc_conv_substring_expr (se, expr);
8334 case EXPR_STRUCTURE:
8335 gfc_conv_structure (se, expr, 0);
8339 gfc_conv_array_constructor_expr (se, expr);
8348 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8349 of an assignment. */
8351 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8353 gfc_conv_expr (se, expr);
8354 /* All numeric lvalues should have empty post chains. If not we need to
8355 figure out a way of rewriting an lvalue so that it has no post chain. */
8356 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8359 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8360 numeric expressions. Used for scalar values where inserting cleanup code
8363 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8367 gcc_assert (expr->ts.type != BT_CHARACTER);
8368 gfc_conv_expr (se, expr);
8371 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8372 gfc_add_modify (&se->pre, val, se->expr);
8374 gfc_add_block_to_block (&se->pre, &se->post);
8378 /* Helper to translate an expression and convert it to a particular type. */
8380 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8382 gfc_conv_expr_val (se, expr);
8383 se->expr = convert (type, se->expr);
8387 /* Converts an expression so that it can be passed by reference. Scalar
8391 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8397 if (ss && ss->info->expr == expr
8398 && ss->info->type == GFC_SS_REFERENCE)
8400 /* Returns a reference to the scalar evaluated outside the loop
8402 gfc_conv_expr (se, expr);
8404 if (expr->ts.type == BT_CHARACTER
8405 && expr->expr_type != EXPR_FUNCTION)
8406 gfc_conv_string_parameter (se);
8408 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8413 if (expr->ts.type == BT_CHARACTER)
8415 gfc_conv_expr (se, expr);
8416 gfc_conv_string_parameter (se);
8420 if (expr->expr_type == EXPR_VARIABLE)
8422 se->want_pointer = 1;
8423 gfc_conv_expr (se, expr);
8426 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8427 gfc_add_modify (&se->pre, var, se->expr);
8428 gfc_add_block_to_block (&se->pre, &se->post);
8431 else if (add_clobber && expr->ref == NULL)
8435 /* FIXME: This fails if var is passed by reference, see PR
8437 var = expr->symtree->n.sym->backend_decl;
8438 clobber = build_clobber (TREE_TYPE (var));
8439 gfc_add_modify (&se->pre, var, clobber);
8444 if (expr->expr_type == EXPR_FUNCTION
8445 && ((expr->value.function.esym
8446 && expr->value.function.esym->result->attr.pointer
8447 && !expr->value.function.esym->result->attr.dimension)
8448 || (!expr->value.function.esym && !expr->ref
8449 && expr->symtree->n.sym->attr.pointer
8450 && !expr->symtree->n.sym->attr.dimension)))
8452 se->want_pointer = 1;
8453 gfc_conv_expr (se, expr);
8454 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8455 gfc_add_modify (&se->pre, var, se->expr);
8460 gfc_conv_expr (se, expr);
8462 /* Create a temporary var to hold the value. */
8463 if (TREE_CONSTANT (se->expr))
8465 tree tmp = se->expr;
8466 STRIP_TYPE_NOPS (tmp);
8467 var = build_decl (input_location,
8468 CONST_DECL, NULL, TREE_TYPE (tmp));
8469 DECL_INITIAL (var) = tmp;
8470 TREE_STATIC (var) = 1;
8475 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8476 gfc_add_modify (&se->pre, var, se->expr);
8479 if (!expr->must_finalize)
8480 gfc_add_block_to_block (&se->pre, &se->post);
8482 /* Take the address of that value. */
8483 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8487 /* Get the _len component for an unlimited polymorphic expression. */
8490 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8493 gfc_ref *ref = expr->ref;
8495 gfc_init_se (&se, NULL);
8496 while (ref && ref->next)
8498 gfc_add_len_component (expr);
8499 gfc_conv_expr (&se, expr);
8500 gfc_add_block_to_block (block, &se.pre);
8501 gcc_assert (se.post.head == NULL_TREE);
8504 gfc_free_ref_list (ref->next);
8509 gfc_free_ref_list (expr->ref);
8516 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8517 statement-list outside of the scalarizer-loop. When code is generated, that
8518 depends on the scalarized expression, it is added to RSE.PRE.
8519 Returns le's _vptr tree and when set the len expressions in to_lenp and
8520 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8524 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8525 gfc_expr * re, gfc_se *rse,
8526 tree * to_lenp, tree * from_lenp)
8529 gfc_expr * vptr_expr;
8530 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8531 bool set_vptr = false, temp_rhs = false;
8532 stmtblock_t *pre = block;
8534 /* Create a temporary for complicated expressions. */
8535 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8536 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8538 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8540 gfc_add_modify (&rse->pre, tmp, rse->expr);
8545 /* Get the _vptr for the left-hand side expression. */
8546 gfc_init_se (&se, NULL);
8547 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8548 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8550 /* Care about _len for unlimited polymorphic entities. */
8551 if (UNLIMITED_POLY (vptr_expr)
8552 || (vptr_expr->ts.type == BT_DERIVED
8553 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8554 to_len = trans_get_upoly_len (block, vptr_expr);
8555 gfc_add_vptr_component (vptr_expr);
8559 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8560 se.want_pointer = 1;
8561 gfc_conv_expr (&se, vptr_expr);
8562 gfc_free_expr (vptr_expr);
8563 gfc_add_block_to_block (block, &se.pre);
8564 gcc_assert (se.post.head == NULL_TREE);
8566 STRIP_NOPS (lhs_vptr);
8568 /* Set the _vptr only when the left-hand side of the assignment is a
8572 /* Get the vptr from the rhs expression only, when it is variable.
8573 Functions are expected to be assigned to a temporary beforehand. */
8574 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8575 ? gfc_find_and_cut_at_last_class_ref (re)
8577 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8579 if (to_len != NULL_TREE)
8581 /* Get the _len information from the rhs. */
8582 if (UNLIMITED_POLY (vptr_expr)
8583 || (vptr_expr->ts.type == BT_DERIVED
8584 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8585 from_len = trans_get_upoly_len (block, vptr_expr);
8587 gfc_add_vptr_component (vptr_expr);
8591 if (re->expr_type == EXPR_VARIABLE
8592 && DECL_P (re->symtree->n.sym->backend_decl)
8593 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8594 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8595 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8596 re->symtree->n.sym->backend_decl))))
8599 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8600 re->symtree->n.sym->backend_decl));
8602 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8603 re->symtree->n.sym->backend_decl));
8605 else if (temp_rhs && re->ts.type == BT_CLASS)
8608 se.expr = gfc_class_vptr_get (rse->expr);
8609 if (UNLIMITED_POLY (re))
8610 from_len = gfc_class_len_get (rse->expr);
8612 else if (re->expr_type != EXPR_NULL)
8613 /* Only when rhs is non-NULL use its declared type for vptr
8615 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8617 /* When the rhs is NULL use the vtab of lhs' declared type. */
8618 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8623 gfc_init_se (&se, NULL);
8624 se.want_pointer = 1;
8625 gfc_conv_expr (&se, vptr_expr);
8626 gfc_free_expr (vptr_expr);
8627 gfc_add_block_to_block (block, &se.pre);
8628 gcc_assert (se.post.head == NULL_TREE);
8630 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8633 if (to_len != NULL_TREE)
8635 /* The _len component needs to be set. Figure how to get the
8636 value of the right-hand side. */
8637 if (from_len == NULL_TREE)
8639 if (rse->string_length != NULL_TREE)
8640 from_len = rse->string_length;
8641 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8643 from_len = gfc_get_expr_charlen (re);
8644 gfc_init_se (&se, NULL);
8645 gfc_conv_expr (&se, re->ts.u.cl->length);
8646 gfc_add_block_to_block (block, &se.pre);
8647 gcc_assert (se.post.head == NULL_TREE);
8648 from_len = gfc_evaluate_now (se.expr, block);
8651 from_len = build_zero_cst (gfc_charlen_type_node);
8653 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8658 /* Return the _len trees only, when requested. */
8662 *from_lenp = from_len;
8667 /* Assign tokens for pointer components. */
8670 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8673 symbol_attribute lhs_attr, rhs_attr;
8674 tree tmp, lhs_tok, rhs_tok;
8675 /* Flag to indicated component refs on the rhs. */
8678 lhs_attr = gfc_caf_attr (expr1);
8679 if (expr2->expr_type != EXPR_NULL)
8681 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8682 if (lhs_attr.codimension && rhs_attr.codimension)
8684 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8685 lhs_tok = build_fold_indirect_ref (lhs_tok);
8688 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8692 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8693 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8696 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8698 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8699 gfc_prepend_expr_to_block (&lse->post, tmp);
8702 else if (lhs_attr.codimension)
8704 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8705 lhs_tok = build_fold_indirect_ref (lhs_tok);
8706 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8707 lhs_tok, null_pointer_node);
8708 gfc_prepend_expr_to_block (&lse->post, tmp);
8712 /* Indentify class valued proc_pointer assignments. */
8715 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8720 while (ref && ref->next)
8723 return ref && ref->type == REF_COMPONENT
8724 && ref->u.c.component->attr.proc_pointer
8725 && expr2->expr_type == EXPR_VARIABLE
8726 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8730 /* Do everything that is needed for a CLASS function expr2. */
8733 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8734 gfc_expr *expr1, gfc_expr *expr2)
8736 tree expr1_vptr = NULL_TREE;
8739 gfc_conv_function_expr (rse, expr2);
8740 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8742 if (expr1->ts.type != BT_CLASS)
8743 rse->expr = gfc_class_data_get (rse->expr);
8746 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8749 gfc_add_block_to_block (block, &rse->pre);
8750 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8751 gfc_add_modify (&lse->pre, tmp, rse->expr);
8753 gfc_add_modify (&lse->pre, expr1_vptr,
8754 fold_convert (TREE_TYPE (expr1_vptr),
8755 gfc_class_vptr_get (tmp)));
8756 rse->expr = gfc_class_data_get (tmp);
8764 gfc_trans_pointer_assign (gfc_code * code)
8766 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8770 /* Generate code for a pointer assignment. */
8773 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8780 tree expr1_vptr = NULL_TREE;
8781 bool scalar, non_proc_pointer_assign;
8784 gfc_start_block (&block);
8786 gfc_init_se (&lse, NULL);
8788 /* Usually testing whether this is not a proc pointer assignment. */
8789 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8791 /* Check whether the expression is a scalar or not; we cannot use
8792 expr1->rank as it can be nonzero for proc pointers. */
8793 ss = gfc_walk_expr (expr1);
8794 scalar = ss == gfc_ss_terminator;
8796 gfc_free_ss_chain (ss);
8798 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8799 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8801 gfc_add_data_component (expr2);
8802 /* The following is required as gfc_add_data_component doesn't
8803 update ts.type if there is a tailing REF_ARRAY. */
8804 expr2->ts.type = BT_DERIVED;
8809 /* Scalar pointers. */
8810 lse.want_pointer = 1;
8811 gfc_conv_expr (&lse, expr1);
8812 gfc_init_se (&rse, NULL);
8813 rse.want_pointer = 1;
8814 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8815 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8817 gfc_conv_expr (&rse, expr2);
8819 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8821 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8823 lse.expr = gfc_class_data_get (lse.expr);
8826 if (expr1->symtree->n.sym->attr.proc_pointer
8827 && expr1->symtree->n.sym->attr.dummy)
8828 lse.expr = build_fold_indirect_ref_loc (input_location,
8831 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8832 && expr2->symtree->n.sym->attr.dummy)
8833 rse.expr = build_fold_indirect_ref_loc (input_location,
8836 gfc_add_block_to_block (&block, &lse.pre);
8837 gfc_add_block_to_block (&block, &rse.pre);
8839 /* Check character lengths if character expression. The test is only
8840 really added if -fbounds-check is enabled. Exclude deferred
8841 character length lefthand sides. */
8842 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8843 && !expr1->ts.deferred
8844 && !expr1->symtree->n.sym->attr.proc_pointer
8845 && !gfc_is_proc_ptr_comp (expr1))
8847 gcc_assert (expr2->ts.type == BT_CHARACTER);
8848 gcc_assert (lse.string_length && rse.string_length);
8849 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8850 lse.string_length, rse.string_length,
8854 /* The assignment to an deferred character length sets the string
8855 length to that of the rhs. */
8856 if (expr1->ts.deferred)
8858 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8859 gfc_add_modify (&block, lse.string_length,
8860 fold_convert (TREE_TYPE (lse.string_length),
8861 rse.string_length));
8862 else if (lse.string_length != NULL)
8863 gfc_add_modify (&block, lse.string_length,
8864 build_zero_cst (TREE_TYPE (lse.string_length)));
8867 gfc_add_modify (&block, lse.expr,
8868 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8870 /* Also set the tokens for pointer components in derived typed
8872 if (flag_coarray == GFC_FCOARRAY_LIB)
8873 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8875 gfc_add_block_to_block (&block, &rse.post);
8876 gfc_add_block_to_block (&block, &lse.post);
8883 tree strlen_rhs = NULL_TREE;
8885 /* Array pointer. Find the last reference on the LHS and if it is an
8886 array section ref, we're dealing with bounds remapping. In this case,
8887 set it to AR_FULL so that gfc_conv_expr_descriptor does
8888 not see it and process the bounds remapping afterwards explicitly. */
8889 for (remap = expr1->ref; remap; remap = remap->next)
8890 if (!remap->next && remap->type == REF_ARRAY
8891 && remap->u.ar.type == AR_SECTION)
8893 rank_remap = (remap && remap->u.ar.end[0]);
8895 gfc_init_se (&lse, NULL);
8897 lse.descriptor_only = 1;
8898 gfc_conv_expr_descriptor (&lse, expr1);
8899 strlen_lhs = lse.string_length;
8902 if (expr2->expr_type == EXPR_NULL)
8904 /* Just set the data pointer to null. */
8905 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8907 else if (rank_remap)
8909 /* If we are rank-remapping, just get the RHS's descriptor and
8910 process this later on. */
8911 gfc_init_se (&rse, NULL);
8912 rse.direct_byref = 1;
8913 rse.byref_noassign = 1;
8915 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8916 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8918 else if (expr2->expr_type == EXPR_FUNCTION)
8920 tree bound[GFC_MAX_DIMENSIONS];
8923 for (i = 0; i < expr2->rank; i++)
8924 bound[i] = NULL_TREE;
8925 tmp = gfc_typenode_for_spec (&expr2->ts);
8926 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8928 GFC_ARRAY_POINTER_CONT, false);
8929 tmp = gfc_create_var (tmp, "ptrtemp");
8930 rse.descriptor_only = 0;
8932 rse.direct_byref = 1;
8933 gfc_conv_expr_descriptor (&rse, expr2);
8934 strlen_rhs = rse.string_length;
8939 gfc_conv_expr_descriptor (&rse, expr2);
8940 strlen_rhs = rse.string_length;
8941 if (expr1->ts.type == BT_CLASS)
8942 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8947 else if (expr2->expr_type == EXPR_VARIABLE)
8949 /* Assign directly to the LHS's descriptor. */
8950 lse.descriptor_only = 0;
8951 lse.direct_byref = 1;
8952 gfc_conv_expr_descriptor (&lse, expr2);
8953 strlen_rhs = lse.string_length;
8955 if (expr1->ts.type == BT_CLASS)
8957 rse.expr = NULL_TREE;
8958 rse.string_length = NULL_TREE;
8959 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8965 /* If the target is not a whole array, use the target array
8966 reference for remap. */
8967 for (remap = expr2->ref; remap; remap = remap->next)
8968 if (remap->type == REF_ARRAY
8969 && remap->u.ar.type == AR_FULL
8974 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8976 gfc_init_se (&rse, NULL);
8977 rse.want_pointer = 1;
8978 gfc_conv_function_expr (&rse, expr2);
8979 if (expr1->ts.type != BT_CLASS)
8981 rse.expr = gfc_class_data_get (rse.expr);
8982 gfc_add_modify (&lse.pre, desc, rse.expr);
8983 /* Set the lhs span. */
8984 tmp = TREE_TYPE (rse.expr);
8985 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8986 tmp = fold_convert (gfc_array_index_type, tmp);
8987 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8991 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8994 gfc_add_block_to_block (&block, &rse.pre);
8995 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8996 gfc_add_modify (&lse.pre, tmp, rse.expr);
8998 gfc_add_modify (&lse.pre, expr1_vptr,
8999 fold_convert (TREE_TYPE (expr1_vptr),
9000 gfc_class_vptr_get (tmp)));
9001 rse.expr = gfc_class_data_get (tmp);
9002 gfc_add_modify (&lse.pre, desc, rse.expr);
9007 /* Assign to a temporary descriptor and then copy that
9008 temporary to the pointer. */
9009 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9010 lse.descriptor_only = 0;
9012 lse.direct_byref = 1;
9013 gfc_conv_expr_descriptor (&lse, expr2);
9014 strlen_rhs = lse.string_length;
9015 gfc_add_modify (&lse.pre, desc, tmp);
9018 gfc_add_block_to_block (&block, &lse.pre);
9020 gfc_add_block_to_block (&block, &rse.pre);
9022 /* If we do bounds remapping, update LHS descriptor accordingly. */
9026 gcc_assert (remap->u.ar.dimen == expr1->rank);
9030 /* Do rank remapping. We already have the RHS's descriptor
9031 converted in rse and now have to build the correct LHS
9032 descriptor for it. */
9034 tree dtype, data, span;
9036 tree lbound, ubound;
9039 dtype = gfc_conv_descriptor_dtype (desc);
9040 tmp = gfc_get_dtype (TREE_TYPE (desc));
9041 gfc_add_modify (&block, dtype, tmp);
9043 /* Copy data pointer. */
9044 data = gfc_conv_descriptor_data_get (rse.expr);
9045 gfc_conv_descriptor_data_set (&block, desc, data);
9047 /* Copy the span. */
9048 if (TREE_CODE (rse.expr) == VAR_DECL
9049 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9050 span = gfc_conv_descriptor_span_get (rse.expr);
9053 tmp = TREE_TYPE (rse.expr);
9054 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9055 span = fold_convert (gfc_array_index_type, tmp);
9057 gfc_conv_descriptor_span_set (&block, desc, span);
9059 /* Copy offset but adjust it such that it would correspond
9060 to a lbound of zero. */
9061 offs = gfc_conv_descriptor_offset_get (rse.expr);
9062 for (dim = 0; dim < expr2->rank; ++dim)
9064 stride = gfc_conv_descriptor_stride_get (rse.expr,
9066 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9068 tmp = fold_build2_loc (input_location, MULT_EXPR,
9069 gfc_array_index_type, stride, lbound);
9070 offs = fold_build2_loc (input_location, PLUS_EXPR,
9071 gfc_array_index_type, offs, tmp);
9073 gfc_conv_descriptor_offset_set (&block, desc, offs);
9075 /* Set the bounds as declared for the LHS and calculate strides as
9076 well as another offset update accordingly. */
9077 stride = gfc_conv_descriptor_stride_get (rse.expr,
9079 for (dim = 0; dim < expr1->rank; ++dim)
9084 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9086 /* Convert declared bounds. */
9087 gfc_init_se (&lower_se, NULL);
9088 gfc_init_se (&upper_se, NULL);
9089 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9090 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9092 gfc_add_block_to_block (&block, &lower_se.pre);
9093 gfc_add_block_to_block (&block, &upper_se.pre);
9095 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9096 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9098 lbound = gfc_evaluate_now (lbound, &block);
9099 ubound = gfc_evaluate_now (ubound, &block);
9101 gfc_add_block_to_block (&block, &lower_se.post);
9102 gfc_add_block_to_block (&block, &upper_se.post);
9104 /* Set bounds in descriptor. */
9105 gfc_conv_descriptor_lbound_set (&block, desc,
9106 gfc_rank_cst[dim], lbound);
9107 gfc_conv_descriptor_ubound_set (&block, desc,
9108 gfc_rank_cst[dim], ubound);
9111 stride = gfc_evaluate_now (stride, &block);
9112 gfc_conv_descriptor_stride_set (&block, desc,
9113 gfc_rank_cst[dim], stride);
9115 /* Update offset. */
9116 offs = gfc_conv_descriptor_offset_get (desc);
9117 tmp = fold_build2_loc (input_location, MULT_EXPR,
9118 gfc_array_index_type, lbound, stride);
9119 offs = fold_build2_loc (input_location, MINUS_EXPR,
9120 gfc_array_index_type, offs, tmp);
9121 offs = gfc_evaluate_now (offs, &block);
9122 gfc_conv_descriptor_offset_set (&block, desc, offs);
9124 /* Update stride. */
9125 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9126 stride = fold_build2_loc (input_location, MULT_EXPR,
9127 gfc_array_index_type, stride, tmp);
9132 /* Bounds remapping. Just shift the lower bounds. */
9134 gcc_assert (expr1->rank == expr2->rank);
9136 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9140 gcc_assert (!remap->u.ar.end[dim]);
9141 gfc_init_se (&lbound_se, NULL);
9142 if (remap->u.ar.start[dim])
9144 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9145 gfc_add_block_to_block (&block, &lbound_se.pre);
9148 /* This remap arises from a target that is not a whole
9149 array. The start expressions will be NULL but we need
9150 the lbounds to be one. */
9151 lbound_se.expr = gfc_index_one_node;
9152 gfc_conv_shift_descriptor_lbound (&block, desc,
9153 dim, lbound_se.expr);
9154 gfc_add_block_to_block (&block, &lbound_se.post);
9159 /* Check string lengths if applicable. The check is only really added
9160 to the output code if -fbounds-check is enabled. */
9161 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9163 gcc_assert (expr2->ts.type == BT_CHARACTER);
9164 gcc_assert (strlen_lhs && strlen_rhs);
9165 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9166 strlen_lhs, strlen_rhs, &block);
9169 /* If rank remapping was done, check with -fcheck=bounds that
9170 the target is at least as large as the pointer. */
9171 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9177 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9178 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9180 lsize = gfc_evaluate_now (lsize, &block);
9181 rsize = gfc_evaluate_now (rsize, &block);
9182 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9185 msg = _("Target of rank remapping is too small (%ld < %ld)");
9186 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9190 if (expr1->ts.type == BT_CHARACTER
9191 && expr1->symtree->n.sym->ts.deferred
9192 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9193 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9195 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9196 if (expr2->expr_type != EXPR_NULL)
9197 gfc_add_modify (&block, tmp,
9198 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9200 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9203 gfc_add_block_to_block (&block, &lse.post);
9205 gfc_add_block_to_block (&block, &rse.post);
9208 return gfc_finish_block (&block);
9212 /* Makes sure se is suitable for passing as a function string parameter. */
9213 /* TODO: Need to check all callers of this function. It may be abused. */
9216 gfc_conv_string_parameter (gfc_se * se)
9220 if (TREE_CODE (se->expr) == STRING_CST)
9222 type = TREE_TYPE (TREE_TYPE (se->expr));
9223 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9227 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9229 if (TREE_CODE (se->expr) != INDIRECT_REF)
9231 type = TREE_TYPE (se->expr);
9232 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9236 type = gfc_get_character_type_len (gfc_default_character_kind,
9238 type = build_pointer_type (type);
9239 se->expr = gfc_build_addr_expr (type, se->expr);
9243 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9247 /* Generate code for assignment of scalar variables. Includes character
9248 strings and derived types with allocatable components.
9249 If you know that the LHS has no allocations, set dealloc to false.
9251 DEEP_COPY has no effect if the typespec TS is not a derived type with
9252 allocatable components. Otherwise, if it is set, an explicit copy of each
9253 allocatable component is made. This is necessary as a simple copy of the
9254 whole object would copy array descriptors as is, so that the lhs's
9255 allocatable components would point to the rhs's after the assignment.
9256 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9257 necessary if the rhs is a non-pointer function, as the allocatable components
9258 are not accessible by other means than the function's result after the
9259 function has returned. It is even more subtle when temporaries are involved,
9260 as the two following examples show:
9261 1. When we evaluate an array constructor, a temporary is created. Thus
9262 there is theoretically no alias possible. However, no deep copy is
9263 made for this temporary, so that if the constructor is made of one or
9264 more variable with allocatable components, those components still point
9265 to the variable's: DEEP_COPY should be set for the assignment from the
9266 temporary to the lhs in that case.
9267 2. When assigning a scalar to an array, we evaluate the scalar value out
9268 of the loop, store it into a temporary variable, and assign from that.
9269 In that case, deep copying when assigning to the temporary would be a
9270 waste of resources; however deep copies should happen when assigning from
9271 the temporary to each array element: again DEEP_COPY should be set for
9272 the assignment from the temporary to the lhs. */
9275 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9276 bool deep_copy, bool dealloc, bool in_coarray)
9282 gfc_init_block (&block);
9284 if (ts.type == BT_CHARACTER)
9289 if (lse->string_length != NULL_TREE)
9291 gfc_conv_string_parameter (lse);
9292 gfc_add_block_to_block (&block, &lse->pre);
9293 llen = lse->string_length;
9296 if (rse->string_length != NULL_TREE)
9298 gfc_conv_string_parameter (rse);
9299 gfc_add_block_to_block (&block, &rse->pre);
9300 rlen = rse->string_length;
9303 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9304 rse->expr, ts.kind);
9306 else if (gfc_bt_struct (ts.type)
9307 && (ts.u.derived->attr.alloc_comp
9308 || (deep_copy && ts.u.derived->attr.pdt_type)))
9310 tree tmp_var = NULL_TREE;
9313 /* Are the rhs and the lhs the same? */
9316 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9317 gfc_build_addr_expr (NULL_TREE, lse->expr),
9318 gfc_build_addr_expr (NULL_TREE, rse->expr));
9319 cond = gfc_evaluate_now (cond, &lse->pre);
9322 /* Deallocate the lhs allocated components as long as it is not
9323 the same as the rhs. This must be done following the assignment
9324 to prevent deallocating data that could be used in the rhs
9328 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9329 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9331 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9333 gfc_add_expr_to_block (&lse->post, tmp);
9336 gfc_add_block_to_block (&block, &rse->pre);
9337 gfc_add_block_to_block (&block, &lse->pre);
9339 gfc_add_modify (&block, lse->expr,
9340 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9342 /* Restore pointer address of coarray components. */
9343 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9345 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9346 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9348 gfc_add_expr_to_block (&block, tmp);
9351 /* Do a deep copy if the rhs is a variable, if it is not the
9355 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9356 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9357 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9359 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9361 gfc_add_expr_to_block (&block, tmp);
9364 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9366 gfc_add_block_to_block (&block, &lse->pre);
9367 gfc_add_block_to_block (&block, &rse->pre);
9368 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9369 TREE_TYPE (lse->expr), rse->expr);
9370 gfc_add_modify (&block, lse->expr, tmp);
9374 gfc_add_block_to_block (&block, &lse->pre);
9375 gfc_add_block_to_block (&block, &rse->pre);
9377 gfc_add_modify (&block, lse->expr,
9378 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9381 gfc_add_block_to_block (&block, &lse->post);
9382 gfc_add_block_to_block (&block, &rse->post);
9384 return gfc_finish_block (&block);
9388 /* There are quite a lot of restrictions on the optimisation in using an
9389 array function assign without a temporary. */
9392 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9395 bool seen_array_ref;
9397 gfc_symbol *sym = expr1->symtree->n.sym;
9399 /* Play it safe with class functions assigned to a derived type. */
9400 if (gfc_is_class_array_function (expr2)
9401 && expr1->ts.type == BT_DERIVED)
9404 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9405 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9408 /* Elemental functions are scalarized so that they don't need a
9409 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9410 they would need special treatment in gfc_trans_arrayfunc_assign. */
9411 if (expr2->value.function.esym != NULL
9412 && expr2->value.function.esym->attr.elemental)
9415 /* Need a temporary if rhs is not FULL or a contiguous section. */
9416 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9419 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9420 if (gfc_ref_needs_temporary_p (expr1->ref))
9423 /* Functions returning pointers or allocatables need temporaries. */
9424 c = expr2->value.function.esym
9425 ? (expr2->value.function.esym->attr.pointer
9426 || expr2->value.function.esym->attr.allocatable)
9427 : (expr2->symtree->n.sym->attr.pointer
9428 || expr2->symtree->n.sym->attr.allocatable);
9432 /* Character array functions need temporaries unless the
9433 character lengths are the same. */
9434 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9436 if (expr1->ts.u.cl->length == NULL
9437 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9440 if (expr2->ts.u.cl->length == NULL
9441 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9444 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9445 expr2->ts.u.cl->length->value.integer) != 0)
9449 /* Check that no LHS component references appear during an array
9450 reference. This is needed because we do not have the means to
9451 span any arbitrary stride with an array descriptor. This check
9452 is not needed for the rhs because the function result has to be
9454 seen_array_ref = false;
9455 for (ref = expr1->ref; ref; ref = ref->next)
9457 if (ref->type == REF_ARRAY)
9458 seen_array_ref= true;
9459 else if (ref->type == REF_COMPONENT && seen_array_ref)
9463 /* Check for a dependency. */
9464 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9465 expr2->value.function.esym,
9466 expr2->value.function.actual,
9470 /* If we have reached here with an intrinsic function, we do not
9471 need a temporary except in the particular case that reallocation
9472 on assignment is active and the lhs is allocatable and a target. */
9473 if (expr2->value.function.isym)
9474 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9476 /* If the LHS is a dummy, we need a temporary if it is not
9478 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9481 /* If the lhs has been host_associated, is in common, a pointer or is
9482 a target and the function is not using a RESULT variable, aliasing
9483 can occur and a temporary is needed. */
9484 if ((sym->attr.host_assoc
9485 || sym->attr.in_common
9486 || sym->attr.pointer
9487 || sym->attr.cray_pointee
9488 || sym->attr.target)
9489 && expr2->symtree != NULL
9490 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9493 /* A PURE function can unconditionally be called without a temporary. */
9494 if (expr2->value.function.esym != NULL
9495 && expr2->value.function.esym->attr.pure)
9498 /* Implicit_pure functions are those which could legally be declared
9500 if (expr2->value.function.esym != NULL
9501 && expr2->value.function.esym->attr.implicit_pure)
9504 if (!sym->attr.use_assoc
9505 && !sym->attr.in_common
9506 && !sym->attr.pointer
9507 && !sym->attr.target
9508 && !sym->attr.cray_pointee
9509 && expr2->value.function.esym)
9511 /* A temporary is not needed if the function is not contained and
9512 the variable is local or host associated and not a pointer or
9514 if (!expr2->value.function.esym->attr.contained)
9517 /* A temporary is not needed if the lhs has never been host
9518 associated and the procedure is contained. */
9519 else if (!sym->attr.host_assoc)
9522 /* A temporary is not needed if the variable is local and not
9523 a pointer, a target or a result. */
9525 && expr2->value.function.esym->ns == sym->ns->parent)
9529 /* Default to temporary use. */
9534 /* Provide the loop info so that the lhs descriptor can be built for
9535 reallocatable assignments from extrinsic function calls. */
9538 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9541 /* Signal that the function call should not be made by
9542 gfc_conv_loop_setup. */
9543 se->ss->is_alloc_lhs = 1;
9544 gfc_init_loopinfo (loop);
9545 gfc_add_ss_to_loop (loop, *ss);
9546 gfc_add_ss_to_loop (loop, se->ss);
9547 gfc_conv_ss_startstride (loop);
9548 gfc_conv_loop_setup (loop, where);
9549 gfc_copy_loopinfo_to_se (se, loop);
9550 gfc_add_block_to_block (&se->pre, &loop->pre);
9551 gfc_add_block_to_block (&se->pre, &loop->post);
9552 se->ss->is_alloc_lhs = 0;
9556 /* For assignment to a reallocatable lhs from intrinsic functions,
9557 replace the se.expr (ie. the result) with a temporary descriptor.
9558 Null the data field so that the library allocates space for the
9559 result. Free the data of the original descriptor after the function,
9560 in case it appears in an argument expression and transfer the
9561 result to the original descriptor. */
9564 fcncall_realloc_result (gfc_se *se, int rank)
9573 /* Use the allocation done by the library. Substitute the lhs
9574 descriptor with a copy, whose data field is nulled.*/
9575 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9576 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9577 desc = build_fold_indirect_ref_loc (input_location, desc);
9579 /* Unallocated, the descriptor does not have a dtype. */
9580 tmp = gfc_conv_descriptor_dtype (desc);
9581 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9583 res_desc = gfc_evaluate_now (desc, &se->pre);
9584 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9585 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9587 /* Free the lhs after the function call and copy the result data to
9588 the lhs descriptor. */
9589 tmp = gfc_conv_descriptor_data_get (desc);
9590 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9591 logical_type_node, tmp,
9592 build_int_cst (TREE_TYPE (tmp), 0));
9593 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9594 tmp = gfc_call_free (tmp);
9595 gfc_add_expr_to_block (&se->post, tmp);
9597 tmp = gfc_conv_descriptor_data_get (res_desc);
9598 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9600 /* Check that the shapes are the same between lhs and expression. */
9601 for (n = 0 ; n < rank; n++)
9604 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9605 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9606 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9607 gfc_array_index_type, tmp, tmp1);
9608 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9609 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9610 gfc_array_index_type, tmp, tmp1);
9611 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9612 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9613 gfc_array_index_type, tmp, tmp1);
9614 tmp = fold_build2_loc (input_location, NE_EXPR,
9615 logical_type_node, tmp,
9616 gfc_index_zero_node);
9617 tmp = gfc_evaluate_now (tmp, &se->post);
9618 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9619 logical_type_node, tmp,
9623 /* 'zero_cond' being true is equal to lhs not being allocated or the
9624 shapes being different. */
9625 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9627 /* Now reset the bounds returned from the function call to bounds based
9628 on the lhs lbounds, except where the lhs is not allocated or the shapes
9629 of 'variable and 'expr' are different. Set the offset accordingly. */
9630 offset = gfc_index_zero_node;
9631 for (n = 0 ; n < rank; n++)
9635 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9636 lbound = fold_build3_loc (input_location, COND_EXPR,
9637 gfc_array_index_type, zero_cond,
9638 gfc_index_one_node, lbound);
9639 lbound = gfc_evaluate_now (lbound, &se->post);
9641 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9642 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9643 gfc_array_index_type, tmp, lbound);
9644 gfc_conv_descriptor_lbound_set (&se->post, desc,
9645 gfc_rank_cst[n], lbound);
9646 gfc_conv_descriptor_ubound_set (&se->post, desc,
9647 gfc_rank_cst[n], tmp);
9649 /* Set stride and accumulate the offset. */
9650 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9651 gfc_conv_descriptor_stride_set (&se->post, desc,
9652 gfc_rank_cst[n], tmp);
9653 tmp = fold_build2_loc (input_location, MULT_EXPR,
9654 gfc_array_index_type, lbound, tmp);
9655 offset = fold_build2_loc (input_location, MINUS_EXPR,
9656 gfc_array_index_type, offset, tmp);
9657 offset = gfc_evaluate_now (offset, &se->post);
9660 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9665 /* Try to translate array(:) = func (...), where func is a transformational
9666 array function, without using a temporary. Returns NULL if this isn't the
9670 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9674 gfc_component *comp = NULL;
9677 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9680 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9682 comp = gfc_get_proc_ptr_comp (expr2);
9684 if (!(expr2->value.function.isym
9685 || (comp && comp->attr.dimension)
9686 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9687 && expr2->value.function.esym->result->attr.dimension)))
9690 gfc_init_se (&se, NULL);
9691 gfc_start_block (&se.pre);
9692 se.want_pointer = 1;
9694 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9696 if (expr1->ts.type == BT_DERIVED
9697 && expr1->ts.u.derived->attr.alloc_comp)
9700 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9702 gfc_add_expr_to_block (&se.pre, tmp);
9705 se.direct_byref = 1;
9706 se.ss = gfc_walk_expr (expr2);
9707 gcc_assert (se.ss != gfc_ss_terminator);
9709 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9710 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9711 Clearly, this cannot be done for an allocatable function result, since
9712 the shape of the result is unknown and, in any case, the function must
9713 correctly take care of the reallocation internally. For intrinsic
9714 calls, the array data is freed and the library takes care of allocation.
9715 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9717 if (flag_realloc_lhs
9718 && gfc_is_reallocatable_lhs (expr1)
9719 && !gfc_expr_attr (expr1).codimension
9720 && !gfc_is_coindexed (expr1)
9721 && !(expr2->value.function.esym
9722 && expr2->value.function.esym->result->attr.allocatable))
9724 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9726 if (!expr2->value.function.isym)
9728 ss = gfc_walk_expr (expr1);
9729 gcc_assert (ss != gfc_ss_terminator);
9731 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9732 ss->is_alloc_lhs = 1;
9735 fcncall_realloc_result (&se, expr1->rank);
9738 gfc_conv_function_expr (&se, expr2);
9739 gfc_add_block_to_block (&se.pre, &se.post);
9742 gfc_cleanup_loop (&loop);
9744 gfc_free_ss_chain (se.ss);
9746 return gfc_finish_block (&se.pre);
9750 /* Try to efficiently translate array(:) = 0. Return NULL if this
9754 gfc_trans_zero_assign (gfc_expr * expr)
9756 tree dest, len, type;
9760 sym = expr->symtree->n.sym;
9761 dest = gfc_get_symbol_decl (sym);
9763 type = TREE_TYPE (dest);
9764 if (POINTER_TYPE_P (type))
9765 type = TREE_TYPE (type);
9766 if (!GFC_ARRAY_TYPE_P (type))
9769 /* Determine the length of the array. */
9770 len = GFC_TYPE_ARRAY_SIZE (type);
9771 if (!len || TREE_CODE (len) != INTEGER_CST)
9774 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9775 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9776 fold_convert (gfc_array_index_type, tmp));
9778 /* If we are zeroing a local array avoid taking its address by emitting
9780 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9781 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9782 dest, build_constructor (TREE_TYPE (dest),
9785 /* Convert arguments to the correct types. */
9786 dest = fold_convert (pvoid_type_node, dest);
9787 len = fold_convert (size_type_node, len);
9789 /* Construct call to __builtin_memset. */
9790 tmp = build_call_expr_loc (input_location,
9791 builtin_decl_explicit (BUILT_IN_MEMSET),
9792 3, dest, integer_zero_node, len);
9793 return fold_convert (void_type_node, tmp);
9797 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9798 that constructs the call to __builtin_memcpy. */
9801 gfc_build_memcpy_call (tree dst, tree src, tree len)
9805 /* Convert arguments to the correct types. */
9806 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9807 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9809 dst = fold_convert (pvoid_type_node, dst);
9811 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9812 src = gfc_build_addr_expr (pvoid_type_node, src);
9814 src = fold_convert (pvoid_type_node, src);
9816 len = fold_convert (size_type_node, len);
9818 /* Construct call to __builtin_memcpy. */
9819 tmp = build_call_expr_loc (input_location,
9820 builtin_decl_explicit (BUILT_IN_MEMCPY),
9822 return fold_convert (void_type_node, tmp);
9826 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9827 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9828 source/rhs, both are gfc_full_array_ref_p which have been checked for
9832 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9834 tree dst, dlen, dtype;
9835 tree src, slen, stype;
9838 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9839 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9841 dtype = TREE_TYPE (dst);
9842 if (POINTER_TYPE_P (dtype))
9843 dtype = TREE_TYPE (dtype);
9844 stype = TREE_TYPE (src);
9845 if (POINTER_TYPE_P (stype))
9846 stype = TREE_TYPE (stype);
9848 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9851 /* Determine the lengths of the arrays. */
9852 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9853 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9855 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9856 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9857 dlen, fold_convert (gfc_array_index_type, tmp));
9859 slen = GFC_TYPE_ARRAY_SIZE (stype);
9860 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9862 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9863 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9864 slen, fold_convert (gfc_array_index_type, tmp));
9866 /* Sanity check that they are the same. This should always be
9867 the case, as we should already have checked for conformance. */
9868 if (!tree_int_cst_equal (slen, dlen))
9871 return gfc_build_memcpy_call (dst, src, dlen);
9875 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9876 this can't be done. EXPR1 is the destination/lhs for which
9877 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9880 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9882 unsigned HOST_WIDE_INT nelem;
9888 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9892 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9893 dtype = TREE_TYPE (dst);
9894 if (POINTER_TYPE_P (dtype))
9895 dtype = TREE_TYPE (dtype);
9896 if (!GFC_ARRAY_TYPE_P (dtype))
9899 /* Determine the lengths of the array. */
9900 len = GFC_TYPE_ARRAY_SIZE (dtype);
9901 if (!len || TREE_CODE (len) != INTEGER_CST)
9904 /* Confirm that the constructor is the same size. */
9905 if (compare_tree_int (len, nelem) != 0)
9908 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9909 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9910 fold_convert (gfc_array_index_type, tmp));
9912 stype = gfc_typenode_for_spec (&expr2->ts);
9913 src = gfc_build_constant_array_constructor (expr2, stype);
9915 stype = TREE_TYPE (src);
9916 if (POINTER_TYPE_P (stype))
9917 stype = TREE_TYPE (stype);
9919 return gfc_build_memcpy_call (dst, src, len);
9923 /* Tells whether the expression is to be treated as a variable reference. */
9926 gfc_expr_is_variable (gfc_expr *expr)
9929 gfc_component *comp;
9930 gfc_symbol *func_ifc;
9932 if (expr->expr_type == EXPR_VARIABLE)
9935 arg = gfc_get_noncopying_intrinsic_argument (expr);
9938 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9939 return gfc_expr_is_variable (arg);
9942 /* A data-pointer-returning function should be considered as a variable
9944 if (expr->expr_type == EXPR_FUNCTION
9945 && expr->ref == NULL)
9947 if (expr->value.function.isym != NULL)
9950 if (expr->value.function.esym != NULL)
9952 func_ifc = expr->value.function.esym;
9957 gcc_assert (expr->symtree);
9958 func_ifc = expr->symtree->n.sym;
9965 comp = gfc_get_proc_ptr_comp (expr);
9966 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9969 func_ifc = comp->ts.interface;
9973 if (expr->expr_type == EXPR_COMPCALL)
9975 gcc_assert (!expr->value.compcall.tbp->is_generic);
9976 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9983 gcc_assert (func_ifc->attr.function
9984 && func_ifc->result != NULL);
9985 return func_ifc->result->attr.pointer;
9989 /* Is the lhs OK for automatic reallocation? */
9992 is_scalar_reallocatable_lhs (gfc_expr *expr)
9996 /* An allocatable variable with no reference. */
9997 if (expr->symtree->n.sym->attr.allocatable
10001 /* All that can be left are allocatable components. However, we do
10002 not check for allocatable components here because the expression
10003 could be an allocatable component of a pointer component. */
10004 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10005 && expr->symtree->n.sym->ts.type != BT_CLASS)
10008 /* Find an allocatable component ref last. */
10009 for (ref = expr->ref; ref; ref = ref->next)
10010 if (ref->type == REF_COMPONENT
10012 && ref->u.c.component->attr.allocatable)
10019 /* Allocate or reallocate scalar lhs, as necessary. */
10022 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10023 tree string_length,
10031 tree size_in_bytes;
10037 if (!expr1 || expr1->rank)
10040 if (!expr2 || expr2->rank)
10043 for (ref = expr1->ref; ref; ref = ref->next)
10044 if (ref->type == REF_SUBSTRING)
10047 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10049 /* Since this is a scalar lhs, we can afford to do this. That is,
10050 there is no risk of side effects being repeated. */
10051 gfc_init_se (&lse, NULL);
10052 lse.want_pointer = 1;
10053 gfc_conv_expr (&lse, expr1);
10055 jump_label1 = gfc_build_label_decl (NULL_TREE);
10056 jump_label2 = gfc_build_label_decl (NULL_TREE);
10058 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10059 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10060 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10062 tmp = build3_v (COND_EXPR, cond,
10063 build1_v (GOTO_EXPR, jump_label1),
10064 build_empty_stmt (input_location));
10065 gfc_add_expr_to_block (block, tmp);
10067 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10069 /* Use the rhs string length and the lhs element size. */
10070 size = string_length;
10071 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10072 tmp = TYPE_SIZE_UNIT (tmp);
10073 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10074 TREE_TYPE (tmp), tmp,
10075 fold_convert (TREE_TYPE (tmp), size));
10079 /* Otherwise use the length in bytes of the rhs. */
10080 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10081 size_in_bytes = size;
10084 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10085 size_in_bytes, size_one_node);
10087 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10089 tree caf_decl, token;
10091 symbol_attribute attr;
10093 gfc_clear_attr (&attr);
10094 gfc_init_se (&caf_se, NULL);
10096 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10097 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10099 gfc_add_block_to_block (block, &caf_se.pre);
10100 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10101 gfc_build_addr_expr (NULL_TREE, token),
10102 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10105 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10107 tmp = build_call_expr_loc (input_location,
10108 builtin_decl_explicit (BUILT_IN_CALLOC),
10109 2, build_one_cst (size_type_node),
10111 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10112 gfc_add_modify (block, lse.expr, tmp);
10116 tmp = build_call_expr_loc (input_location,
10117 builtin_decl_explicit (BUILT_IN_MALLOC),
10119 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10120 gfc_add_modify (block, lse.expr, tmp);
10123 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10125 /* Deferred characters need checking for lhs and rhs string
10126 length. Other deferred parameter variables will have to
10128 tmp = build1_v (GOTO_EXPR, jump_label2);
10129 gfc_add_expr_to_block (block, tmp);
10131 tmp = build1_v (LABEL_EXPR, jump_label1);
10132 gfc_add_expr_to_block (block, tmp);
10134 /* For a deferred length character, reallocate if lengths of lhs and
10135 rhs are different. */
10136 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10138 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10140 fold_convert (TREE_TYPE (lse.string_length),
10142 /* Jump past the realloc if the lengths are the same. */
10143 tmp = build3_v (COND_EXPR, cond,
10144 build1_v (GOTO_EXPR, jump_label2),
10145 build_empty_stmt (input_location));
10146 gfc_add_expr_to_block (block, tmp);
10147 tmp = build_call_expr_loc (input_location,
10148 builtin_decl_explicit (BUILT_IN_REALLOC),
10149 2, fold_convert (pvoid_type_node, lse.expr),
10151 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10152 gfc_add_modify (block, lse.expr, tmp);
10153 tmp = build1_v (LABEL_EXPR, jump_label2);
10154 gfc_add_expr_to_block (block, tmp);
10156 /* Update the lhs character length. */
10157 size = string_length;
10158 gfc_add_modify (block, lse.string_length,
10159 fold_convert (TREE_TYPE (lse.string_length), size));
10163 /* Check for assignments of the type
10167 to make sure we do not check for reallocation unneccessarily. */
10171 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10173 gfc_actual_arglist *a;
10176 switch (expr2->expr_type)
10178 case EXPR_VARIABLE:
10179 return gfc_dep_compare_expr (expr1, expr2) == 0;
10181 case EXPR_FUNCTION:
10182 if (expr2->value.function.esym
10183 && expr2->value.function.esym->attr.elemental)
10185 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10188 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10193 else if (expr2->value.function.isym
10194 && expr2->value.function.isym->elemental)
10196 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10199 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10208 switch (expr2->value.op.op)
10210 case INTRINSIC_NOT:
10211 case INTRINSIC_UPLUS:
10212 case INTRINSIC_UMINUS:
10213 case INTRINSIC_PARENTHESES:
10214 return is_runtime_conformable (expr1, expr2->value.op.op1);
10216 case INTRINSIC_PLUS:
10217 case INTRINSIC_MINUS:
10218 case INTRINSIC_TIMES:
10219 case INTRINSIC_DIVIDE:
10220 case INTRINSIC_POWER:
10221 case INTRINSIC_AND:
10223 case INTRINSIC_EQV:
10224 case INTRINSIC_NEQV:
10231 case INTRINSIC_EQ_OS:
10232 case INTRINSIC_NE_OS:
10233 case INTRINSIC_GT_OS:
10234 case INTRINSIC_GE_OS:
10235 case INTRINSIC_LT_OS:
10236 case INTRINSIC_LE_OS:
10238 e1 = expr2->value.op.op1;
10239 e2 = expr2->value.op.op2;
10241 if (e1->rank == 0 && e2->rank > 0)
10242 return is_runtime_conformable (expr1, e2);
10243 else if (e1->rank > 0 && e2->rank == 0)
10244 return is_runtime_conformable (expr1, e1);
10245 else if (e1->rank > 0 && e2->rank > 0)
10246 return is_runtime_conformable (expr1, e1)
10247 && is_runtime_conformable (expr1, e2);
10265 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10266 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10267 bool class_realloc)
10269 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10270 vec<tree, va_gc> *args = NULL;
10272 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10275 /* Generate allocation of the lhs. */
10281 tmp = gfc_vptr_size_get (vptr);
10282 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10283 ? gfc_class_data_get (lse->expr) : lse->expr;
10284 gfc_init_block (&alloc);
10285 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10286 tmp = fold_build2_loc (input_location, EQ_EXPR,
10287 logical_type_node, class_han,
10288 build_int_cst (prvoid_type_node, 0));
10289 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10291 PRED_FORTRAN_FAIL_ALLOC),
10292 gfc_finish_block (&alloc),
10293 build_empty_stmt (input_location));
10294 gfc_add_expr_to_block (&lse->pre, tmp);
10297 fcn = gfc_vptr_copy_get (vptr);
10299 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10300 ? gfc_class_data_get (rse->expr) : rse->expr;
10303 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10304 || INDIRECT_REF_P (tmp)
10305 || (rhs->ts.type == BT_DERIVED
10306 && rhs->ts.u.derived->attr.unlimited_polymorphic
10307 && !rhs->ts.u.derived->attr.pointer
10308 && !rhs->ts.u.derived->attr.allocatable)
10309 || (UNLIMITED_POLY (rhs)
10310 && !CLASS_DATA (rhs)->attr.pointer
10311 && !CLASS_DATA (rhs)->attr.allocatable))
10312 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10314 vec_safe_push (args, tmp);
10315 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10316 ? gfc_class_data_get (lse->expr) : lse->expr;
10317 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10318 || INDIRECT_REF_P (tmp)
10319 || (lhs->ts.type == BT_DERIVED
10320 && lhs->ts.u.derived->attr.unlimited_polymorphic
10321 && !lhs->ts.u.derived->attr.pointer
10322 && !lhs->ts.u.derived->attr.allocatable)
10323 || (UNLIMITED_POLY (lhs)
10324 && !CLASS_DATA (lhs)->attr.pointer
10325 && !CLASS_DATA (lhs)->attr.allocatable))
10326 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10328 vec_safe_push (args, tmp);
10330 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10332 if (to_len != NULL_TREE && !integer_zerop (from_len))
10335 vec_safe_push (args, from_len);
10336 vec_safe_push (args, to_len);
10337 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10339 tmp = fold_build2_loc (input_location, GT_EXPR,
10340 logical_type_node, from_len,
10341 build_zero_cst (TREE_TYPE (from_len)));
10342 return fold_build3_loc (input_location, COND_EXPR,
10343 void_type_node, tmp,
10351 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10352 ? gfc_class_data_get (lse->expr) : lse->expr;
10353 stmtblock_t tblock;
10354 gfc_init_block (&tblock);
10355 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10356 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10357 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10358 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10359 /* When coming from a ptr_copy lhs and rhs are swapped. */
10360 gfc_add_modify_loc (input_location, &tblock, rhst,
10361 fold_convert (TREE_TYPE (rhst), tmp));
10362 return gfc_finish_block (&tblock);
10366 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10367 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10368 init_flag indicates initialization expressions and dealloc that no
10369 deallocate prior assignment is needed (if in doubt, set true).
10370 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10371 routine instead of a pointer assignment. Alias resolution is only done,
10372 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10373 where it is known, that newly allocated memory on the lhs can never be
10374 an alias of the rhs. */
10377 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10378 bool dealloc, bool use_vptr_copy, bool may_alias)
10383 gfc_ss *lss_section;
10390 bool scalar_to_array;
10391 tree string_length;
10393 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10394 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10395 bool is_poly_assign;
10397 /* Assignment of the form lhs = rhs. */
10398 gfc_start_block (&block);
10400 gfc_init_se (&lse, NULL);
10401 gfc_init_se (&rse, NULL);
10403 /* Walk the lhs. */
10404 lss = gfc_walk_expr (expr1);
10405 if (gfc_is_reallocatable_lhs (expr1))
10407 lss->no_bounds_check = 1;
10408 if (!(expr2->expr_type == EXPR_FUNCTION
10409 && expr2->value.function.isym != NULL
10410 && !(expr2->value.function.isym->elemental
10411 || expr2->value.function.isym->conversion)))
10412 lss->is_alloc_lhs = 1;
10415 lss->no_bounds_check = expr1->no_bounds_check;
10419 if ((expr1->ts.type == BT_DERIVED)
10420 && (gfc_is_class_array_function (expr2)
10421 || gfc_is_alloc_class_scalar_function (expr2)))
10422 expr2->must_finalize = 1;
10424 /* Checking whether a class assignment is desired is quite complicated and
10425 needed at two locations, so do it once only before the information is
10427 lhs_attr = gfc_expr_attr (expr1);
10428 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10429 || (lhs_attr.allocatable && !lhs_attr.dimension))
10430 && (expr1->ts.type == BT_CLASS
10431 || gfc_is_class_array_ref (expr1, NULL)
10432 || gfc_is_class_scalar_expr (expr1)
10433 || gfc_is_class_array_ref (expr2, NULL)
10434 || gfc_is_class_scalar_expr (expr2));
10437 /* Only analyze the expressions for coarray properties, when in coarray-lib
10439 if (flag_coarray == GFC_FCOARRAY_LIB)
10441 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10442 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10445 if (lss != gfc_ss_terminator)
10447 /* The assignment needs scalarization. */
10450 /* Find a non-scalar SS from the lhs. */
10451 while (lss_section != gfc_ss_terminator
10452 && lss_section->info->type != GFC_SS_SECTION)
10453 lss_section = lss_section->next;
10455 gcc_assert (lss_section != gfc_ss_terminator);
10457 /* Initialize the scalarizer. */
10458 gfc_init_loopinfo (&loop);
10460 /* Walk the rhs. */
10461 rss = gfc_walk_expr (expr2);
10462 if (rss == gfc_ss_terminator)
10463 /* The rhs is scalar. Add a ss for the expression. */
10464 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10465 /* When doing a class assign, then the handle to the rhs needs to be a
10466 pointer to allow for polymorphism. */
10467 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10468 rss->info->type = GFC_SS_REFERENCE;
10470 rss->no_bounds_check = expr2->no_bounds_check;
10471 /* Associate the SS with the loop. */
10472 gfc_add_ss_to_loop (&loop, lss);
10473 gfc_add_ss_to_loop (&loop, rss);
10475 /* Calculate the bounds of the scalarization. */
10476 gfc_conv_ss_startstride (&loop);
10477 /* Enable loop reversal. */
10478 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10479 loop.reverse[n] = GFC_ENABLE_REVERSE;
10480 /* Resolve any data dependencies in the statement. */
10482 gfc_conv_resolve_dependencies (&loop, lss, rss);
10483 /* Setup the scalarizing loops. */
10484 gfc_conv_loop_setup (&loop, &expr2->where);
10486 /* Setup the gfc_se structures. */
10487 gfc_copy_loopinfo_to_se (&lse, &loop);
10488 gfc_copy_loopinfo_to_se (&rse, &loop);
10491 gfc_mark_ss_chain_used (rss, 1);
10492 if (loop.temp_ss == NULL)
10495 gfc_mark_ss_chain_used (lss, 1);
10499 lse.ss = loop.temp_ss;
10500 gfc_mark_ss_chain_used (lss, 3);
10501 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10504 /* Allow the scalarizer to workshare array assignments. */
10505 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10506 == OMPWS_WORKSHARE_FLAG
10507 && loop.temp_ss == NULL)
10509 maybe_workshare = true;
10510 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10513 /* Start the scalarized loop body. */
10514 gfc_start_scalarized_body (&loop, &body);
10517 gfc_init_block (&body);
10519 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10521 /* Translate the expression. */
10522 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10523 && lhs_caf_attr.codimension;
10524 gfc_conv_expr (&rse, expr2);
10526 /* Deal with the case of a scalar class function assigned to a derived type. */
10527 if (gfc_is_alloc_class_scalar_function (expr2)
10528 && expr1->ts.type == BT_DERIVED)
10530 rse.expr = gfc_class_data_get (rse.expr);
10531 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10534 /* Stabilize a string length for temporaries. */
10535 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10536 && !(VAR_P (rse.string_length)
10537 || TREE_CODE (rse.string_length) == PARM_DECL
10538 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10539 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10540 else if (expr2->ts.type == BT_CHARACTER)
10542 if (expr1->ts.deferred && gfc_check_dependency (expr1, expr2, true))
10543 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10544 string_length = rse.string_length;
10547 string_length = NULL_TREE;
10551 gfc_conv_tmp_array_ref (&lse);
10552 if (expr2->ts.type == BT_CHARACTER)
10553 lse.string_length = string_length;
10557 gfc_conv_expr (&lse, expr1);
10558 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10560 && gfc_expr_attr (expr1).allocatable
10567 tmp = INDIRECT_REF_P (lse.expr)
10568 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10570 /* We should only get array references here. */
10571 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10572 || TREE_CODE (tmp) == ARRAY_REF);
10574 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10575 or the array itself(ARRAY_REF). */
10576 tmp = TREE_OPERAND (tmp, 0);
10578 /* Provide the address of the array. */
10579 if (TREE_CODE (lse.expr) == ARRAY_REF)
10580 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10582 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10583 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10584 msg = _("Assignment of scalar to unallocated array");
10585 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10586 &expr1->where, msg);
10589 /* Deallocate the lhs parameterized components if required. */
10590 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10591 && !expr1->symtree->n.sym->attr.associate_var)
10593 if (expr1->ts.type == BT_DERIVED
10594 && expr1->ts.u.derived
10595 && expr1->ts.u.derived->attr.pdt_type)
10597 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10599 gfc_add_expr_to_block (&lse.pre, tmp);
10601 else if (expr1->ts.type == BT_CLASS
10602 && CLASS_DATA (expr1)->ts.u.derived
10603 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10605 tmp = gfc_class_data_get (lse.expr);
10606 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10608 gfc_add_expr_to_block (&lse.pre, tmp);
10613 /* Assignments of scalar derived types with allocatable components
10614 to arrays must be done with a deep copy and the rhs temporary
10615 must have its components deallocated afterwards. */
10616 scalar_to_array = (expr2->ts.type == BT_DERIVED
10617 && expr2->ts.u.derived->attr.alloc_comp
10618 && !gfc_expr_is_variable (expr2)
10619 && expr1->rank && !expr2->rank);
10620 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10622 && expr1->ts.u.derived->attr.alloc_comp
10623 && gfc_is_alloc_class_scalar_function (expr2));
10624 if (scalar_to_array && dealloc)
10626 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10627 gfc_prepend_expr_to_block (&loop.post, tmp);
10630 /* When assigning a character function result to a deferred-length variable,
10631 the function call must happen before the (re)allocation of the lhs -
10632 otherwise the character length of the result is not known.
10633 NOTE 1: This relies on having the exact dependence of the length type
10634 parameter available to the caller; gfortran saves it in the .mod files.
10635 NOTE 2: Vector array references generate an index temporary that must
10636 not go outside the loop. Otherwise, variables should not generate
10638 NOTE 3: The concatenation operation generates a temporary pointer,
10639 whose allocation must go to the innermost loop.
10640 NOTE 4: Elemental functions may generate a temporary, too. */
10641 if (flag_realloc_lhs
10642 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10643 && !(lss != gfc_ss_terminator
10644 && rss != gfc_ss_terminator
10645 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10646 || (expr2->expr_type == EXPR_FUNCTION
10647 && expr2->value.function.esym != NULL
10648 && expr2->value.function.esym->attr.elemental)
10649 || (expr2->expr_type == EXPR_FUNCTION
10650 && expr2->value.function.isym != NULL
10651 && expr2->value.function.isym->elemental)
10652 || (expr2->expr_type == EXPR_OP
10653 && expr2->value.op.op == INTRINSIC_CONCAT))))
10654 gfc_add_block_to_block (&block, &rse.pre);
10656 /* Nullify the allocatable components corresponding to those of the lhs
10657 derived type, so that the finalization of the function result does not
10658 affect the lhs of the assignment. Prepend is used to ensure that the
10659 nullification occurs before the call to the finalizer. In the case of
10660 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10661 as part of the deep copy. */
10662 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10663 && (gfc_is_class_array_function (expr2)
10664 || gfc_is_alloc_class_scalar_function (expr2)))
10667 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10668 gfc_prepend_expr_to_block (&rse.post, tmp);
10669 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10670 gfc_add_block_to_block (&loop.post, &rse.post);
10675 if (is_poly_assign)
10676 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10677 use_vptr_copy || (lhs_attr.allocatable
10678 && !lhs_attr.dimension),
10679 flag_realloc_lhs && !lhs_attr.pointer);
10680 else if (flag_coarray == GFC_FCOARRAY_LIB
10681 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10682 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10683 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10685 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10686 allocatable component, because those need to be accessed via the
10687 caf-runtime. No need to check for coindexes here, because resolve
10688 has rewritten those already. */
10690 gfc_actual_arglist a1, a2;
10691 /* Clear the structures to prevent accessing garbage. */
10692 memset (&code, '\0', sizeof (gfc_code));
10693 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10694 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10699 code.ext.actual = &a1;
10700 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10701 tmp = gfc_conv_intrinsic_subroutine (&code);
10703 else if (!is_poly_assign && expr2->must_finalize
10704 && expr1->ts.type == BT_CLASS
10705 && expr2->ts.type == BT_CLASS)
10707 /* This case comes about when the scalarizer provides array element
10708 references. Use the vptr copy function, since this does a deep
10709 copy of allocatable components, without which the finalizer call */
10710 tmp = gfc_get_vptr_from_expr (rse.expr);
10711 if (tmp != NULL_TREE)
10713 tree fcn = gfc_vptr_copy_get (tmp);
10714 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10715 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10716 tmp = build_call_expr_loc (input_location,
10718 gfc_build_addr_expr (NULL, rse.expr),
10719 gfc_build_addr_expr (NULL, lse.expr));
10723 /* If nothing else works, do it the old fashioned way! */
10724 if (tmp == NULL_TREE)
10725 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10726 gfc_expr_is_variable (expr2)
10728 || expr2->expr_type == EXPR_ARRAY,
10729 !(l_is_temp || init_flag) && dealloc,
10730 expr1->symtree->n.sym->attr.codimension);
10732 /* Add the pre blocks to the body. */
10733 gfc_add_block_to_block (&body, &rse.pre);
10734 gfc_add_block_to_block (&body, &lse.pre);
10735 gfc_add_expr_to_block (&body, tmp);
10736 /* Add the post blocks to the body. */
10737 gfc_add_block_to_block (&body, &rse.post);
10738 gfc_add_block_to_block (&body, &lse.post);
10740 if (lss == gfc_ss_terminator)
10742 /* F2003: Add the code for reallocation on assignment. */
10743 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10744 && !is_poly_assign)
10745 alloc_scalar_allocatable_for_assignment (&block, string_length,
10748 /* Use the scalar assignment as is. */
10749 gfc_add_block_to_block (&block, &body);
10753 gcc_assert (lse.ss == gfc_ss_terminator
10754 && rse.ss == gfc_ss_terminator);
10758 gfc_trans_scalarized_loop_boundary (&loop, &body);
10760 /* We need to copy the temporary to the actual lhs. */
10761 gfc_init_se (&lse, NULL);
10762 gfc_init_se (&rse, NULL);
10763 gfc_copy_loopinfo_to_se (&lse, &loop);
10764 gfc_copy_loopinfo_to_se (&rse, &loop);
10766 rse.ss = loop.temp_ss;
10769 gfc_conv_tmp_array_ref (&rse);
10770 gfc_conv_expr (&lse, expr1);
10772 gcc_assert (lse.ss == gfc_ss_terminator
10773 && rse.ss == gfc_ss_terminator);
10775 if (expr2->ts.type == BT_CHARACTER)
10776 rse.string_length = string_length;
10778 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10780 gfc_add_expr_to_block (&body, tmp);
10783 /* F2003: Allocate or reallocate lhs of allocatable array. */
10784 if (flag_realloc_lhs
10785 && gfc_is_reallocatable_lhs (expr1)
10787 && !is_runtime_conformable (expr1, expr2))
10789 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10790 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10791 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10792 if (tmp != NULL_TREE)
10793 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10796 if (maybe_workshare)
10797 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10799 /* Generate the copying loops. */
10800 gfc_trans_scalarizing_loops (&loop, &body);
10802 /* Wrap the whole thing up. */
10803 gfc_add_block_to_block (&block, &loop.pre);
10804 gfc_add_block_to_block (&block, &loop.post);
10806 gfc_cleanup_loop (&loop);
10809 return gfc_finish_block (&block);
10813 /* Check whether EXPR is a copyable array. */
10816 copyable_array_p (gfc_expr * expr)
10818 if (expr->expr_type != EXPR_VARIABLE)
10821 /* First check it's an array. */
10822 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10825 if (!gfc_full_array_ref_p (expr->ref, NULL))
10828 /* Next check that it's of a simple enough type. */
10829 switch (expr->ts.type)
10841 return !expr->ts.u.derived->attr.alloc_comp;
10850 /* Translate an assignment. */
10853 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10854 bool dealloc, bool use_vptr_copy, bool may_alias)
10858 /* Special case a single function returning an array. */
10859 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10861 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10866 /* Special case assigning an array to zero. */
10867 if (copyable_array_p (expr1)
10868 && is_zero_initializer_p (expr2))
10870 tmp = gfc_trans_zero_assign (expr1);
10875 /* Special case copying one array to another. */
10876 if (copyable_array_p (expr1)
10877 && copyable_array_p (expr2)
10878 && gfc_compare_types (&expr1->ts, &expr2->ts)
10879 && !gfc_check_dependency (expr1, expr2, 0))
10881 tmp = gfc_trans_array_copy (expr1, expr2);
10886 /* Special case initializing an array from a constant array constructor. */
10887 if (copyable_array_p (expr1)
10888 && expr2->expr_type == EXPR_ARRAY
10889 && gfc_compare_types (&expr1->ts, &expr2->ts))
10891 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10896 if (UNLIMITED_POLY (expr1) && expr1->rank
10897 && expr2->ts.type != BT_CLASS)
10898 use_vptr_copy = true;
10900 /* Fallback to the scalarizer to generate explicit loops. */
10901 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10902 use_vptr_copy, may_alias);
10906 gfc_trans_init_assign (gfc_code * code)
10908 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10912 gfc_trans_assign (gfc_code * code)
10914 return gfc_trans_assignment (code->expr1, code->expr2, false, true);