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 v = wlhs.to_shwi ();
3067 /* 1**something is always 1. */
3068 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3071 else if (v == 2 || v == 4 || v == 8 || v == 16)
3073 /* 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3074 1<<(4*n), but we have to make sure to return zero if the
3075 number of bits is too large. */
3084 type = TREE_TYPE (lse.expr);
3089 shift = fold_build2_loc (input_location, PLUS_EXPR,
3090 TREE_TYPE (rse.expr),
3091 rse.expr, rse.expr);
3093 shift = fold_build2_loc (input_location, MULT_EXPR,
3094 TREE_TYPE (rse.expr),
3095 build_int_cst (TREE_TYPE (rse.expr), 3),
3098 shift = fold_build2_loc (input_location, MULT_EXPR,
3099 TREE_TYPE (rse.expr),
3100 build_int_cst (TREE_TYPE (rse.expr), 4),
3105 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3106 build_int_cst (type, 1), shift);
3107 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3108 rse.expr, build_int_cst (type, 0));
3109 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3110 build_int_cst (type, 0));
3111 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3112 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3113 rse.expr, num_bits);
3114 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3115 build_int_cst (type, 0), cond);
3120 /* (-1)**n is 1 - ((n & 1) << 1) */
3124 type = TREE_TYPE (lse.expr);
3125 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3126 rse.expr, build_int_cst (type, 1));
3127 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3128 tmp, build_int_cst (type, 1));
3129 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3130 build_int_cst (type, 1), tmp);
3136 gfc_int4_type_node = gfc_get_int_type (4);
3138 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3139 library routine. But in the end, we have to convert the result back
3140 if this case applies -- with res_ikind_K, we keep track whether operand K
3141 falls into this case. */
3145 kind = expr->value.op.op1->ts.kind;
3146 switch (expr->value.op.op2->ts.type)
3149 ikind = expr->value.op.op2->ts.kind;
3154 rse.expr = convert (gfc_int4_type_node, rse.expr);
3155 res_ikind_2 = ikind;
3177 if (expr->value.op.op1->ts.type == BT_INTEGER)
3179 lse.expr = convert (gfc_int4_type_node, lse.expr);
3206 switch (expr->value.op.op1->ts.type)
3209 if (kind == 3) /* Case 16 was not handled properly above. */
3211 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3215 /* Use builtins for real ** int4. */
3221 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3225 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3229 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3233 /* Use the __builtin_powil() only if real(kind=16) is
3234 actually the C long double type. */
3235 if (!gfc_real16_is_float128)
3236 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3244 /* If we don't have a good builtin for this, go for the
3245 library function. */
3247 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3251 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3260 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3264 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3272 se->expr = build_call_expr_loc (input_location,
3273 fndecl, 2, lse.expr, rse.expr);
3275 /* Convert the result back if it is of wrong integer kind. */
3276 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3278 /* We want the maximum of both operand kinds as result. */
3279 if (res_ikind_1 < res_ikind_2)
3280 res_ikind_1 = res_ikind_2;
3281 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3286 /* Generate code to allocate a string temporary. */
3289 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3294 if (gfc_can_put_var_on_stack (len))
3296 /* Create a temporary variable to hold the result. */
3297 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3298 TREE_TYPE (len), len,
3299 build_int_cst (TREE_TYPE (len), 1));
3300 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3302 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3303 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3305 tmp = build_array_type (TREE_TYPE (type), tmp);
3307 var = gfc_create_var (tmp, "str");
3308 var = gfc_build_addr_expr (type, var);
3312 /* Allocate a temporary to hold the result. */
3313 var = gfc_create_var (type, "pstr");
3314 gcc_assert (POINTER_TYPE_P (type));
3315 tmp = TREE_TYPE (type);
3316 if (TREE_CODE (tmp) == ARRAY_TYPE)
3317 tmp = TREE_TYPE (tmp);
3318 tmp = TYPE_SIZE_UNIT (tmp);
3319 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3320 fold_convert (size_type_node, len),
3321 fold_convert (size_type_node, tmp));
3322 tmp = gfc_call_malloc (&se->pre, type, tmp);
3323 gfc_add_modify (&se->pre, var, tmp);
3325 /* Free the temporary afterwards. */
3326 tmp = gfc_call_free (var);
3327 gfc_add_expr_to_block (&se->post, tmp);
3334 /* Handle a string concatenation operation. A temporary will be allocated to
3338 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3341 tree len, type, var, tmp, fndecl;
3343 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3344 && expr->value.op.op2->ts.type == BT_CHARACTER);
3345 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3347 gfc_init_se (&lse, se);
3348 gfc_conv_expr (&lse, expr->value.op.op1);
3349 gfc_conv_string_parameter (&lse);
3350 gfc_init_se (&rse, se);
3351 gfc_conv_expr (&rse, expr->value.op.op2);
3352 gfc_conv_string_parameter (&rse);
3354 gfc_add_block_to_block (&se->pre, &lse.pre);
3355 gfc_add_block_to_block (&se->pre, &rse.pre);
3357 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3358 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3359 if (len == NULL_TREE)
3361 len = fold_build2_loc (input_location, PLUS_EXPR,
3362 gfc_charlen_type_node,
3363 fold_convert (gfc_charlen_type_node,
3365 fold_convert (gfc_charlen_type_node,
3366 rse.string_length));
3369 type = build_pointer_type (type);
3371 var = gfc_conv_string_tmp (se, type, len);
3373 /* Do the actual concatenation. */
3374 if (expr->ts.kind == 1)
3375 fndecl = gfor_fndecl_concat_string;
3376 else if (expr->ts.kind == 4)
3377 fndecl = gfor_fndecl_concat_string_char4;
3381 tmp = build_call_expr_loc (input_location,
3382 fndecl, 6, len, var, lse.string_length, lse.expr,
3383 rse.string_length, rse.expr);
3384 gfc_add_expr_to_block (&se->pre, tmp);
3386 /* Add the cleanup for the operands. */
3387 gfc_add_block_to_block (&se->pre, &rse.post);
3388 gfc_add_block_to_block (&se->pre, &lse.post);
3391 se->string_length = len;
3394 /* Translates an op expression. Common (binary) cases are handled by this
3395 function, others are passed on. Recursion is used in either case.
3396 We use the fact that (op1.ts == op2.ts) (except for the power
3398 Operators need no special handling for scalarized expressions as long as
3399 they call gfc_conv_simple_val to get their operands.
3400 Character strings get special handling. */
3403 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3405 enum tree_code code;
3414 switch (expr->value.op.op)
3416 case INTRINSIC_PARENTHESES:
3417 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3418 && flag_protect_parens)
3420 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3421 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3426 case INTRINSIC_UPLUS:
3427 gfc_conv_expr (se, expr->value.op.op1);
3430 case INTRINSIC_UMINUS:
3431 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3435 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3438 case INTRINSIC_PLUS:
3442 case INTRINSIC_MINUS:
3446 case INTRINSIC_TIMES:
3450 case INTRINSIC_DIVIDE:
3451 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3452 an integer, we must round towards zero, so we use a
3454 if (expr->ts.type == BT_INTEGER)
3455 code = TRUNC_DIV_EXPR;
3460 case INTRINSIC_POWER:
3461 gfc_conv_power_op (se, expr);
3464 case INTRINSIC_CONCAT:
3465 gfc_conv_concat_op (se, expr);
3469 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3474 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3478 /* EQV and NEQV only work on logicals, but since we represent them
3479 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3481 case INTRINSIC_EQ_OS:
3489 case INTRINSIC_NE_OS:
3490 case INTRINSIC_NEQV:
3497 case INTRINSIC_GT_OS:
3504 case INTRINSIC_GE_OS:
3511 case INTRINSIC_LT_OS:
3518 case INTRINSIC_LE_OS:
3524 case INTRINSIC_USER:
3525 case INTRINSIC_ASSIGN:
3526 /* These should be converted into function calls by the frontend. */
3530 fatal_error (input_location, "Unknown intrinsic op");
3534 /* The only exception to this is **, which is handled separately anyway. */
3535 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3537 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3541 gfc_init_se (&lse, se);
3542 gfc_conv_expr (&lse, expr->value.op.op1);
3543 gfc_add_block_to_block (&se->pre, &lse.pre);
3546 gfc_init_se (&rse, se);
3547 gfc_conv_expr (&rse, expr->value.op.op2);
3548 gfc_add_block_to_block (&se->pre, &rse.pre);
3552 gfc_conv_string_parameter (&lse);
3553 gfc_conv_string_parameter (&rse);
3555 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3556 rse.string_length, rse.expr,
3557 expr->value.op.op1->ts.kind,
3559 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3560 gfc_add_block_to_block (&lse.post, &rse.post);
3563 type = gfc_typenode_for_spec (&expr->ts);
3567 /* The result of logical ops is always logical_type_node. */
3568 tmp = fold_build2_loc (input_location, code, logical_type_node,
3569 lse.expr, rse.expr);
3570 se->expr = convert (type, tmp);
3573 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3575 /* Add the post blocks. */
3576 gfc_add_block_to_block (&se->post, &rse.post);
3577 gfc_add_block_to_block (&se->post, &lse.post);
3580 /* If a string's length is one, we convert it to a single character. */
3583 gfc_string_to_single_character (tree len, tree str, int kind)
3587 || !tree_fits_uhwi_p (len)
3588 || !POINTER_TYPE_P (TREE_TYPE (str)))
3591 if (TREE_INT_CST_LOW (len) == 1)
3593 str = fold_convert (gfc_get_pchar_type (kind), str);
3594 return build_fold_indirect_ref_loc (input_location, str);
3598 && TREE_CODE (str) == ADDR_EXPR
3599 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3600 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3601 && array_ref_low_bound (TREE_OPERAND (str, 0))
3602 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3603 && TREE_INT_CST_LOW (len) > 1
3604 && TREE_INT_CST_LOW (len)
3605 == (unsigned HOST_WIDE_INT)
3606 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3608 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3609 ret = build_fold_indirect_ref_loc (input_location, ret);
3610 if (TREE_CODE (ret) == INTEGER_CST)
3612 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3613 int i, length = TREE_STRING_LENGTH (string_cst);
3614 const char *ptr = TREE_STRING_POINTER (string_cst);
3616 for (i = 1; i < length; i++)
3629 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3632 if (sym->backend_decl)
3634 /* This becomes the nominal_type in
3635 function.c:assign_parm_find_data_types. */
3636 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3637 /* This becomes the passed_type in
3638 function.c:assign_parm_find_data_types. C promotes char to
3639 integer for argument passing. */
3640 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3642 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3647 /* If we have a constant character expression, make it into an
3649 if ((*expr)->expr_type == EXPR_CONSTANT)
3654 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3655 (int)(*expr)->value.character.string[0]);
3656 if ((*expr)->ts.kind != gfc_c_int_kind)
3658 /* The expr needs to be compatible with a C int. If the
3659 conversion fails, then the 2 causes an ICE. */
3660 ts.type = BT_INTEGER;
3661 ts.kind = gfc_c_int_kind;
3662 gfc_convert_type (*expr, &ts, 2);
3665 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3667 if ((*expr)->ref == NULL)
3669 se->expr = gfc_string_to_single_character
3670 (build_int_cst (integer_type_node, 1),
3671 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3673 ((*expr)->symtree->n.sym)),
3678 gfc_conv_variable (se, *expr);
3679 se->expr = gfc_string_to_single_character
3680 (build_int_cst (integer_type_node, 1),
3681 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3689 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3690 if STR is a string literal, otherwise return -1. */
3693 gfc_optimize_len_trim (tree len, tree str, int kind)
3696 && TREE_CODE (str) == ADDR_EXPR
3697 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3698 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3699 && array_ref_low_bound (TREE_OPERAND (str, 0))
3700 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3701 && tree_fits_uhwi_p (len)
3702 && tree_to_uhwi (len) >= 1
3703 && tree_to_uhwi (len)
3704 == (unsigned HOST_WIDE_INT)
3705 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3707 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3708 folded = build_fold_indirect_ref_loc (input_location, folded);
3709 if (TREE_CODE (folded) == INTEGER_CST)
3711 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3712 int length = TREE_STRING_LENGTH (string_cst);
3713 const char *ptr = TREE_STRING_POINTER (string_cst);
3715 for (; length > 0; length--)
3716 if (ptr[length - 1] != ' ')
3725 /* Helper to build a call to memcmp. */
3728 build_memcmp_call (tree s1, tree s2, tree n)
3732 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3733 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3735 s1 = fold_convert (pvoid_type_node, s1);
3737 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3738 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3740 s2 = fold_convert (pvoid_type_node, s2);
3742 n = fold_convert (size_type_node, n);
3744 tmp = build_call_expr_loc (input_location,
3745 builtin_decl_explicit (BUILT_IN_MEMCMP),
3748 return fold_convert (integer_type_node, tmp);
3751 /* Compare two strings. If they are all single characters, the result is the
3752 subtraction of them. Otherwise, we build a library call. */
3755 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3756 enum tree_code code)
3762 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3763 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3765 sc1 = gfc_string_to_single_character (len1, str1, kind);
3766 sc2 = gfc_string_to_single_character (len2, str2, kind);
3768 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3770 /* Deal with single character specially. */
3771 sc1 = fold_convert (integer_type_node, sc1);
3772 sc2 = fold_convert (integer_type_node, sc2);
3773 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3777 if ((code == EQ_EXPR || code == NE_EXPR)
3779 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3781 /* If one string is a string literal with LEN_TRIM longer
3782 than the length of the second string, the strings
3784 int len = gfc_optimize_len_trim (len1, str1, kind);
3785 if (len > 0 && compare_tree_int (len2, len) < 0)
3786 return integer_one_node;
3787 len = gfc_optimize_len_trim (len2, str2, kind);
3788 if (len > 0 && compare_tree_int (len1, len) < 0)
3789 return integer_one_node;
3792 /* We can compare via memcpy if the strings are known to be equal
3793 in length and they are
3795 - kind=4 and the comparison is for (in)equality. */
3797 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3798 && tree_int_cst_equal (len1, len2)
3799 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3804 chartype = gfc_get_char_type (kind);
3805 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3806 fold_convert (TREE_TYPE(len1),
3807 TYPE_SIZE_UNIT(chartype)),
3809 return build_memcmp_call (str1, str2, tmp);
3812 /* Build a call for the comparison. */
3814 fndecl = gfor_fndecl_compare_string;
3816 fndecl = gfor_fndecl_compare_string_char4;
3820 return build_call_expr_loc (input_location, fndecl, 4,
3821 len1, str1, len2, str2);
3825 /* Return the backend_decl for a procedure pointer component. */
3828 get_proc_ptr_comp (gfc_expr *e)
3834 gfc_init_se (&comp_se, NULL);
3835 e2 = gfc_copy_expr (e);
3836 /* We have to restore the expr type later so that gfc_free_expr frees
3837 the exact same thing that was allocated.
3838 TODO: This is ugly. */
3839 old_type = e2->expr_type;
3840 e2->expr_type = EXPR_VARIABLE;
3841 gfc_conv_expr (&comp_se, e2);
3842 e2->expr_type = old_type;
3844 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3848 /* Convert a typebound function reference from a class object. */
3850 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3855 if (!VAR_P (base_object))
3857 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3858 gfc_add_modify (&se->pre, var, base_object);
3860 se->expr = gfc_class_vptr_get (base_object);
3861 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3863 while (ref && ref->next)
3865 gcc_assert (ref && ref->type == REF_COMPONENT);
3866 if (ref->u.c.sym->attr.extension)
3867 conv_parent_component_references (se, ref);
3868 gfc_conv_component_ref (se, ref);
3869 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3874 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3878 if (gfc_is_proc_ptr_comp (expr))
3879 tmp = get_proc_ptr_comp (expr);
3880 else if (sym->attr.dummy)
3882 tmp = gfc_get_symbol_decl (sym);
3883 if (sym->attr.proc_pointer)
3884 tmp = build_fold_indirect_ref_loc (input_location,
3886 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3887 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3891 if (!sym->backend_decl)
3892 sym->backend_decl = gfc_get_extern_function_decl (sym);
3894 TREE_USED (sym->backend_decl) = 1;
3896 tmp = sym->backend_decl;
3898 if (sym->attr.cray_pointee)
3900 /* TODO - make the cray pointee a pointer to a procedure,
3901 assign the pointer to it and use it for the call. This
3903 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3904 gfc_get_symbol_decl (sym->cp_pointer));
3905 tmp = gfc_evaluate_now (tmp, &se->pre);
3908 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3910 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3911 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3918 /* Initialize MAPPING. */
3921 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3923 mapping->syms = NULL;
3924 mapping->charlens = NULL;
3928 /* Free all memory held by MAPPING (but not MAPPING itself). */
3931 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3933 gfc_interface_sym_mapping *sym;
3934 gfc_interface_sym_mapping *nextsym;
3936 gfc_charlen *nextcl;
3938 for (sym = mapping->syms; sym; sym = nextsym)
3940 nextsym = sym->next;
3941 sym->new_sym->n.sym->formal = NULL;
3942 gfc_free_symbol (sym->new_sym->n.sym);
3943 gfc_free_expr (sym->expr);
3944 free (sym->new_sym);
3947 for (cl = mapping->charlens; cl; cl = nextcl)
3950 gfc_free_expr (cl->length);
3956 /* Return a copy of gfc_charlen CL. Add the returned structure to
3957 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3959 static gfc_charlen *
3960 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3963 gfc_charlen *new_charlen;
3965 new_charlen = gfc_get_charlen ();
3966 new_charlen->next = mapping->charlens;
3967 new_charlen->length = gfc_copy_expr (cl->length);
3969 mapping->charlens = new_charlen;
3974 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3975 array variable that can be used as the actual argument for dummy
3976 argument SYM. Add any initialization code to BLOCK. PACKED is as
3977 for gfc_get_nodesc_array_type and DATA points to the first element
3978 in the passed array. */
3981 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3982 gfc_packed packed, tree data)
3987 type = gfc_typenode_for_spec (&sym->ts);
3988 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3989 !sym->attr.target && !sym->attr.pointer
3990 && !sym->attr.proc_pointer);
3992 var = gfc_create_var (type, "ifm");
3993 gfc_add_modify (block, var, fold_convert (type, data));
3999 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4000 and offset of descriptorless array type TYPE given that it has the same
4001 size as DESC. Add any set-up code to BLOCK. */
4004 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4011 offset = gfc_index_zero_node;
4012 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4014 dim = gfc_rank_cst[n];
4015 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4016 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4018 GFC_TYPE_ARRAY_LBOUND (type, n)
4019 = gfc_conv_descriptor_lbound_get (desc, dim);
4020 GFC_TYPE_ARRAY_UBOUND (type, n)
4021 = gfc_conv_descriptor_ubound_get (desc, dim);
4023 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4025 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4026 gfc_array_index_type,
4027 gfc_conv_descriptor_ubound_get (desc, dim),
4028 gfc_conv_descriptor_lbound_get (desc, dim));
4029 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4030 gfc_array_index_type,
4031 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4032 tmp = gfc_evaluate_now (tmp, block);
4033 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4035 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4036 GFC_TYPE_ARRAY_LBOUND (type, n),
4037 GFC_TYPE_ARRAY_STRIDE (type, n));
4038 offset = fold_build2_loc (input_location, MINUS_EXPR,
4039 gfc_array_index_type, offset, tmp);
4041 offset = gfc_evaluate_now (offset, block);
4042 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4046 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4047 in SE. The caller may still use se->expr and se->string_length after
4048 calling this function. */
4051 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4052 gfc_symbol * sym, gfc_se * se,
4055 gfc_interface_sym_mapping *sm;
4059 gfc_symbol *new_sym;
4061 gfc_symtree *new_symtree;
4063 /* Create a new symbol to represent the actual argument. */
4064 new_sym = gfc_new_symbol (sym->name, NULL);
4065 new_sym->ts = sym->ts;
4066 new_sym->as = gfc_copy_array_spec (sym->as);
4067 new_sym->attr.referenced = 1;
4068 new_sym->attr.dimension = sym->attr.dimension;
4069 new_sym->attr.contiguous = sym->attr.contiguous;
4070 new_sym->attr.codimension = sym->attr.codimension;
4071 new_sym->attr.pointer = sym->attr.pointer;
4072 new_sym->attr.allocatable = sym->attr.allocatable;
4073 new_sym->attr.flavor = sym->attr.flavor;
4074 new_sym->attr.function = sym->attr.function;
4076 /* Ensure that the interface is available and that
4077 descriptors are passed for array actual arguments. */
4078 if (sym->attr.flavor == FL_PROCEDURE)
4080 new_sym->formal = expr->symtree->n.sym->formal;
4081 new_sym->attr.always_explicit
4082 = expr->symtree->n.sym->attr.always_explicit;
4085 /* Create a fake symtree for it. */
4087 new_symtree = gfc_new_symtree (&root, sym->name);
4088 new_symtree->n.sym = new_sym;
4089 gcc_assert (new_symtree == root);
4091 /* Create a dummy->actual mapping. */
4092 sm = XCNEW (gfc_interface_sym_mapping);
4093 sm->next = mapping->syms;
4095 sm->new_sym = new_symtree;
4096 sm->expr = gfc_copy_expr (expr);
4099 /* Stabilize the argument's value. */
4100 if (!sym->attr.function && se)
4101 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4103 if (sym->ts.type == BT_CHARACTER)
4105 /* Create a copy of the dummy argument's length. */
4106 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4107 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4109 /* If the length is specified as "*", record the length that
4110 the caller is passing. We should use the callee's length
4111 in all other cases. */
4112 if (!new_sym->ts.u.cl->length && se)
4114 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4115 new_sym->ts.u.cl->backend_decl = se->string_length;
4122 /* Use the passed value as-is if the argument is a function. */
4123 if (sym->attr.flavor == FL_PROCEDURE)
4126 /* If the argument is a pass-by-value scalar, use the value as is. */
4127 else if (!sym->attr.dimension && sym->attr.value)
4130 /* If the argument is either a string or a pointer to a string,
4131 convert it to a boundless character type. */
4132 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4134 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4135 tmp = build_pointer_type (tmp);
4136 if (sym->attr.pointer)
4137 value = build_fold_indirect_ref_loc (input_location,
4141 value = fold_convert (tmp, value);
4144 /* If the argument is a scalar, a pointer to an array or an allocatable,
4146 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4147 value = build_fold_indirect_ref_loc (input_location,
4150 /* For character(*), use the actual argument's descriptor. */
4151 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4152 value = build_fold_indirect_ref_loc (input_location,
4155 /* If the argument is an array descriptor, use it to determine
4156 information about the actual argument's shape. */
4157 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4158 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4160 /* Get the actual argument's descriptor. */
4161 desc = build_fold_indirect_ref_loc (input_location,
4164 /* Create the replacement variable. */
4165 tmp = gfc_conv_descriptor_data_get (desc);
4166 value = gfc_get_interface_mapping_array (&se->pre, sym,
4169 /* Use DESC to work out the upper bounds, strides and offset. */
4170 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4173 /* Otherwise we have a packed array. */
4174 value = gfc_get_interface_mapping_array (&se->pre, sym,
4175 PACKED_FULL, se->expr);
4177 new_sym->backend_decl = value;
4181 /* Called once all dummy argument mappings have been added to MAPPING,
4182 but before the mapping is used to evaluate expressions. Pre-evaluate
4183 the length of each argument, adding any initialization code to PRE and
4184 any finalization code to POST. */
4187 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4188 stmtblock_t * pre, stmtblock_t * post)
4190 gfc_interface_sym_mapping *sym;
4194 for (sym = mapping->syms; sym; sym = sym->next)
4195 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4196 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4198 expr = sym->new_sym->n.sym->ts.u.cl->length;
4199 gfc_apply_interface_mapping_to_expr (mapping, expr);
4200 gfc_init_se (&se, NULL);
4201 gfc_conv_expr (&se, expr);
4202 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4203 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4204 gfc_add_block_to_block (pre, &se.pre);
4205 gfc_add_block_to_block (post, &se.post);
4207 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4212 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4216 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4217 gfc_constructor_base base)
4220 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4222 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4225 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4226 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4227 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4233 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4237 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4242 for (; ref; ref = ref->next)
4246 for (n = 0; n < ref->u.ar.dimen; n++)
4248 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4249 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4250 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4259 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4260 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4266 /* Convert intrinsic function calls into result expressions. */
4269 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4277 arg1 = expr->value.function.actual->expr;
4278 if (expr->value.function.actual->next)
4279 arg2 = expr->value.function.actual->next->expr;
4283 sym = arg1->symtree->n.sym;
4285 if (sym->attr.dummy)
4290 switch (expr->value.function.isym->id)
4293 /* TODO figure out why this condition is necessary. */
4294 if (sym->attr.function
4295 && (arg1->ts.u.cl->length == NULL
4296 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4297 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4300 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4303 case GFC_ISYM_LEN_TRIM:
4304 new_expr = gfc_copy_expr (arg1);
4305 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4310 gfc_replace_expr (arg1, new_expr);
4314 if (!sym->as || sym->as->rank == 0)
4317 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4319 dup = mpz_get_si (arg2->value.integer);
4324 dup = sym->as->rank;
4328 for (; d < dup; d++)
4332 if (!sym->as->upper[d] || !sym->as->lower[d])
4334 gfc_free_expr (new_expr);
4338 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4339 gfc_get_int_expr (gfc_default_integer_kind,
4341 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4343 new_expr = gfc_multiply (new_expr, tmp);
4349 case GFC_ISYM_LBOUND:
4350 case GFC_ISYM_UBOUND:
4351 /* TODO These implementations of lbound and ubound do not limit if
4352 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4354 if (!sym->as || sym->as->rank == 0)
4357 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4358 d = mpz_get_si (arg2->value.integer) - 1;
4362 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4364 if (sym->as->lower[d])
4365 new_expr = gfc_copy_expr (sym->as->lower[d]);
4369 if (sym->as->upper[d])
4370 new_expr = gfc_copy_expr (sym->as->upper[d]);
4378 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4382 gfc_replace_expr (expr, new_expr);
4388 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4389 gfc_interface_mapping * mapping)
4391 gfc_formal_arglist *f;
4392 gfc_actual_arglist *actual;
4394 actual = expr->value.function.actual;
4395 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4397 for (; f && actual; f = f->next, actual = actual->next)
4402 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4405 if (map_expr->symtree->n.sym->attr.dimension)
4410 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4412 for (d = 0; d < as->rank; d++)
4414 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4415 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4418 expr->value.function.esym->as = as;
4421 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4423 expr->value.function.esym->ts.u.cl->length
4424 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4426 gfc_apply_interface_mapping_to_expr (mapping,
4427 expr->value.function.esym->ts.u.cl->length);
4432 /* EXPR is a copy of an expression that appeared in the interface
4433 associated with MAPPING. Walk it recursively looking for references to
4434 dummy arguments that MAPPING maps to actual arguments. Replace each such
4435 reference with a reference to the associated actual argument. */
4438 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4441 gfc_interface_sym_mapping *sym;
4442 gfc_actual_arglist *actual;
4447 /* Copying an expression does not copy its length, so do that here. */
4448 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4450 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4451 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4454 /* Apply the mapping to any references. */
4455 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4457 /* ...and to the expression's symbol, if it has one. */
4458 /* TODO Find out why the condition on expr->symtree had to be moved into
4459 the loop rather than being outside it, as originally. */
4460 for (sym = mapping->syms; sym; sym = sym->next)
4461 if (expr->symtree && sym->old == expr->symtree->n.sym)
4463 if (sym->new_sym->n.sym->backend_decl)
4464 expr->symtree = sym->new_sym;
4466 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4469 /* ...and to subexpressions in expr->value. */
4470 switch (expr->expr_type)
4475 case EXPR_SUBSTRING:
4479 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4480 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4484 for (actual = expr->value.function.actual; actual; actual = actual->next)
4485 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4487 if (expr->value.function.esym == NULL
4488 && expr->value.function.isym != NULL
4489 && expr->value.function.actual
4490 && expr->value.function.actual->expr
4491 && expr->value.function.actual->expr->symtree
4492 && gfc_map_intrinsic_function (expr, mapping))
4495 for (sym = mapping->syms; sym; sym = sym->next)
4496 if (sym->old == expr->value.function.esym)
4498 expr->value.function.esym = sym->new_sym->n.sym;
4499 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4500 expr->value.function.esym->result = sym->new_sym->n.sym;
4505 case EXPR_STRUCTURE:
4506 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4519 /* Evaluate interface expression EXPR using MAPPING. Store the result
4523 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4524 gfc_se * se, gfc_expr * expr)
4526 expr = gfc_copy_expr (expr);
4527 gfc_apply_interface_mapping_to_expr (mapping, expr);
4528 gfc_conv_expr (se, expr);
4529 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4530 gfc_free_expr (expr);
4534 /* Returns a reference to a temporary array into which a component of
4535 an actual argument derived type array is copied and then returned
4536 after the function call. */
4538 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4539 sym_intent intent, bool formal_ptr)
4547 gfc_array_info *info;
4557 gfc_init_se (&lse, NULL);
4558 gfc_init_se (&rse, NULL);
4560 /* Walk the argument expression. */
4561 rss = gfc_walk_expr (expr);
4563 gcc_assert (rss != gfc_ss_terminator);
4565 /* Initialize the scalarizer. */
4566 gfc_init_loopinfo (&loop);
4567 gfc_add_ss_to_loop (&loop, rss);
4569 /* Calculate the bounds of the scalarization. */
4570 gfc_conv_ss_startstride (&loop);
4572 /* Build an ss for the temporary. */
4573 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4574 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4576 base_type = gfc_typenode_for_spec (&expr->ts);
4577 if (GFC_ARRAY_TYPE_P (base_type)
4578 || GFC_DESCRIPTOR_TYPE_P (base_type))
4579 base_type = gfc_get_element_type (base_type);
4581 if (expr->ts.type == BT_CLASS)
4582 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4584 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4585 ? expr->ts.u.cl->backend_decl
4589 parmse->string_length = loop.temp_ss->info->string_length;
4591 /* Associate the SS with the loop. */
4592 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4594 /* Setup the scalarizing loops. */
4595 gfc_conv_loop_setup (&loop, &expr->where);
4597 /* Pass the temporary descriptor back to the caller. */
4598 info = &loop.temp_ss->info->data.array;
4599 parmse->expr = info->descriptor;
4601 /* Setup the gfc_se structures. */
4602 gfc_copy_loopinfo_to_se (&lse, &loop);
4603 gfc_copy_loopinfo_to_se (&rse, &loop);
4606 lse.ss = loop.temp_ss;
4607 gfc_mark_ss_chain_used (rss, 1);
4608 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4610 /* Start the scalarized loop body. */
4611 gfc_start_scalarized_body (&loop, &body);
4613 /* Translate the expression. */
4614 gfc_conv_expr (&rse, expr);
4616 /* Reset the offset for the function call since the loop
4617 is zero based on the data pointer. Note that the temp
4618 comes first in the loop chain since it is added second. */
4619 if (gfc_is_class_array_function (expr))
4621 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4622 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4623 gfc_index_zero_node);
4626 gfc_conv_tmp_array_ref (&lse);
4628 if (intent != INTENT_OUT)
4630 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4631 gfc_add_expr_to_block (&body, tmp);
4632 gcc_assert (rse.ss == gfc_ss_terminator);
4633 gfc_trans_scalarizing_loops (&loop, &body);
4637 /* Make sure that the temporary declaration survives by merging
4638 all the loop declarations into the current context. */
4639 for (n = 0; n < loop.dimen; n++)
4641 gfc_merge_block_scope (&body);
4642 body = loop.code[loop.order[n]];
4644 gfc_merge_block_scope (&body);
4647 /* Add the post block after the second loop, so that any
4648 freeing of allocated memory is done at the right time. */
4649 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4651 /**********Copy the temporary back again.*********/
4653 gfc_init_se (&lse, NULL);
4654 gfc_init_se (&rse, NULL);
4656 /* Walk the argument expression. */
4657 lss = gfc_walk_expr (expr);
4658 rse.ss = loop.temp_ss;
4661 /* Initialize the scalarizer. */
4662 gfc_init_loopinfo (&loop2);
4663 gfc_add_ss_to_loop (&loop2, lss);
4665 dimen = rse.ss->dimen;
4667 /* Skip the write-out loop for this case. */
4668 if (gfc_is_class_array_function (expr))
4669 goto class_array_fcn;
4671 /* Calculate the bounds of the scalarization. */
4672 gfc_conv_ss_startstride (&loop2);
4674 /* Setup the scalarizing loops. */
4675 gfc_conv_loop_setup (&loop2, &expr->where);
4677 gfc_copy_loopinfo_to_se (&lse, &loop2);
4678 gfc_copy_loopinfo_to_se (&rse, &loop2);
4680 gfc_mark_ss_chain_used (lss, 1);
4681 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4683 /* Declare the variable to hold the temporary offset and start the
4684 scalarized loop body. */
4685 offset = gfc_create_var (gfc_array_index_type, NULL);
4686 gfc_start_scalarized_body (&loop2, &body);
4688 /* Build the offsets for the temporary from the loop variables. The
4689 temporary array has lbounds of zero and strides of one in all
4690 dimensions, so this is very simple. The offset is only computed
4691 outside the innermost loop, so the overall transfer could be
4692 optimized further. */
4693 info = &rse.ss->info->data.array;
4695 tmp_index = gfc_index_zero_node;
4696 for (n = dimen - 1; n > 0; n--)
4699 tmp = rse.loop->loopvar[n];
4700 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4701 tmp, rse.loop->from[n]);
4702 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4705 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4706 gfc_array_index_type,
4707 rse.loop->to[n-1], rse.loop->from[n-1]);
4708 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4709 gfc_array_index_type,
4710 tmp_str, gfc_index_one_node);
4712 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4713 gfc_array_index_type, tmp, tmp_str);
4716 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4717 gfc_array_index_type,
4718 tmp_index, rse.loop->from[0]);
4719 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4721 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4722 gfc_array_index_type,
4723 rse.loop->loopvar[0], offset);
4725 /* Now use the offset for the reference. */
4726 tmp = build_fold_indirect_ref_loc (input_location,
4728 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4730 if (expr->ts.type == BT_CHARACTER)
4731 rse.string_length = expr->ts.u.cl->backend_decl;
4733 gfc_conv_expr (&lse, expr);
4735 gcc_assert (lse.ss == gfc_ss_terminator);
4737 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4738 gfc_add_expr_to_block (&body, tmp);
4740 /* Generate the copying loops. */
4741 gfc_trans_scalarizing_loops (&loop2, &body);
4743 /* Wrap the whole thing up by adding the second loop to the post-block
4744 and following it by the post-block of the first loop. In this way,
4745 if the temporary needs freeing, it is done after use! */
4746 if (intent != INTENT_IN)
4748 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4749 gfc_add_block_to_block (&parmse->post, &loop2.post);
4754 gfc_add_block_to_block (&parmse->post, &loop.post);
4756 gfc_cleanup_loop (&loop);
4757 gfc_cleanup_loop (&loop2);
4759 /* Pass the string length to the argument expression. */
4760 if (expr->ts.type == BT_CHARACTER)
4761 parmse->string_length = expr->ts.u.cl->backend_decl;
4763 /* Determine the offset for pointer formal arguments and set the
4767 size = gfc_index_one_node;
4768 offset = gfc_index_zero_node;
4769 for (n = 0; n < dimen; n++)
4771 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4773 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4774 gfc_array_index_type, tmp,
4775 gfc_index_one_node);
4776 gfc_conv_descriptor_ubound_set (&parmse->pre,
4780 gfc_conv_descriptor_lbound_set (&parmse->pre,
4783 gfc_index_one_node);
4784 size = gfc_evaluate_now (size, &parmse->pre);
4785 offset = fold_build2_loc (input_location, MINUS_EXPR,
4786 gfc_array_index_type,
4788 offset = gfc_evaluate_now (offset, &parmse->pre);
4789 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4790 gfc_array_index_type,
4791 rse.loop->to[n], rse.loop->from[n]);
4792 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4793 gfc_array_index_type,
4794 tmp, gfc_index_one_node);
4795 size = fold_build2_loc (input_location, MULT_EXPR,
4796 gfc_array_index_type, size, tmp);
4799 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4803 /* We want either the address for the data or the address of the descriptor,
4804 depending on the mode of passing array arguments. */
4806 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4808 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4814 /* Generate the code for argument list functions. */
4817 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4819 /* Pass by value for g77 %VAL(arg), pass the address
4820 indirectly for %LOC, else by reference. Thus %REF
4821 is a "do-nothing" and %LOC is the same as an F95
4823 if (strcmp (name, "%VAL") == 0)
4824 gfc_conv_expr (se, expr);
4825 else if (strcmp (name, "%LOC") == 0)
4827 gfc_conv_expr_reference (se, expr);
4828 se->expr = gfc_build_addr_expr (NULL, se->expr);
4830 else if (strcmp (name, "%REF") == 0)
4831 gfc_conv_expr_reference (se, expr);
4833 gfc_error ("Unknown argument list function at %L", &expr->where);
4837 /* This function tells whether the middle-end representation of the expression
4838 E given as input may point to data otherwise accessible through a variable
4840 It is assumed that the only expressions that may alias are variables,
4841 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4843 This function is used to decide whether freeing an expression's allocatable
4844 components is safe or should be avoided.
4846 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4847 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4848 is necessary because for array constructors, aliasing depends on how
4850 - If E is an array constructor used as argument to an elemental procedure,
4851 the array, which is generated through shallow copy by the scalarizer,
4852 is used directly and can alias the expressions it was copied from.
4853 - If E is an array constructor used as argument to a non-elemental
4854 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4855 the array as in the previous case, but then that array is used
4856 to initialize a new descriptor through deep copy. There is no alias
4857 possible in that case.
4858 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4862 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4866 if (e->expr_type == EXPR_VARIABLE)
4868 else if (e->expr_type == EXPR_FUNCTION)
4870 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4872 if (proc_ifc->result != NULL
4873 && ((proc_ifc->result->ts.type == BT_CLASS
4874 && proc_ifc->result->ts.u.derived->attr.is_class
4875 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4876 || proc_ifc->result->attr.pointer))
4881 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4884 for (c = gfc_constructor_first (e->value.constructor);
4885 c; c = gfc_constructor_next (c))
4887 && expr_may_alias_variables (c->expr, array_may_alias))
4894 /* Generate code for a procedure call. Note can return se->post != NULL.
4895 If se->direct_byref is set then se->expr contains the return parameter.
4896 Return nonzero, if the call has alternate specifiers.
4897 'expr' is only needed for procedure pointer components. */
4900 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4901 gfc_actual_arglist * args, gfc_expr * expr,
4902 vec<tree, va_gc> *append_args)
4904 gfc_interface_mapping mapping;
4905 vec<tree, va_gc> *arglist;
4906 vec<tree, va_gc> *retargs;
4910 gfc_array_info *info;
4917 vec<tree, va_gc> *stringargs;
4918 vec<tree, va_gc> *optionalargs;
4920 gfc_formal_arglist *formal;
4921 gfc_actual_arglist *arg;
4922 int has_alternate_specifier = 0;
4923 bool need_interface_mapping;
4931 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4932 gfc_component *comp = NULL;
4939 optionalargs = NULL;
4944 comp = gfc_get_proc_ptr_comp (expr);
4946 bool elemental_proc = (comp
4947 && comp->ts.interface
4948 && comp->ts.interface->attr.elemental)
4949 || (comp && comp->attr.elemental)
4950 || sym->attr.elemental;
4954 if (!elemental_proc)
4956 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4957 if (se->ss->info->useflags)
4959 gcc_assert ((!comp && gfc_return_by_reference (sym)
4960 && sym->result->attr.dimension)
4961 || (comp && comp->attr.dimension)
4962 || gfc_is_class_array_function (expr));
4963 gcc_assert (se->loop != NULL);
4964 /* Access the previously obtained result. */
4965 gfc_conv_tmp_array_ref (se);
4969 info = &se->ss->info->data.array;
4974 gfc_init_block (&post);
4975 gfc_init_interface_mapping (&mapping);
4978 formal = gfc_sym_get_dummy_args (sym);
4979 need_interface_mapping = sym->attr.dimension ||
4980 (sym->ts.type == BT_CHARACTER
4981 && sym->ts.u.cl->length
4982 && sym->ts.u.cl->length->expr_type
4987 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4988 need_interface_mapping = comp->attr.dimension ||
4989 (comp->ts.type == BT_CHARACTER
4990 && comp->ts.u.cl->length
4991 && comp->ts.u.cl->length->expr_type
4995 base_object = NULL_TREE;
4996 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4997 is the third and fourth argument to such a function call a value
4998 denoting the number of elements to copy (i.e., most of the time the
4999 length of a deferred length string). */
5000 ulim_copy = (formal == NULL)
5001 && UNLIMITED_POLY (sym)
5002 && comp && (strcmp ("_copy", comp->name) == 0);
5004 /* Evaluate the arguments. */
5005 for (arg = args, argc = 0; arg != NULL;
5006 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5008 bool finalized = false;
5011 fsym = formal ? formal->sym : NULL;
5012 parm_kind = MISSING;
5014 /* If the procedure requires an explicit interface, the actual
5015 argument is passed according to the corresponding formal
5016 argument. If the corresponding formal argument is a POINTER,
5017 ALLOCATABLE or assumed shape, we do not use g77's calling
5018 convention, and pass the address of the array descriptor
5019 instead. Otherwise we use g77's calling convention, in other words
5020 pass the array data pointer without descriptor. */
5021 bool nodesc_arg = fsym != NULL
5022 && !(fsym->attr.pointer || fsym->attr.allocatable)
5024 && fsym->as->type != AS_ASSUMED_SHAPE
5025 && fsym->as->type != AS_ASSUMED_RANK;
5027 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5029 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5031 /* Class array expressions are sometimes coming completely unadorned
5032 with either arrayspec or _data component. Correct that here.
5033 OOP-TODO: Move this to the frontend. */
5034 if (e && e->expr_type == EXPR_VARIABLE
5036 && e->ts.type == BT_CLASS
5037 && (CLASS_DATA (e)->attr.codimension
5038 || CLASS_DATA (e)->attr.dimension))
5040 gfc_typespec temp_ts = e->ts;
5041 gfc_add_class_array_ref (e);
5047 if (se->ignore_optional)
5049 /* Some intrinsics have already been resolved to the correct
5053 else if (arg->label)
5055 has_alternate_specifier = 1;
5060 gfc_init_se (&parmse, NULL);
5062 /* For scalar arguments with VALUE attribute which are passed by
5063 value, pass "0" and a hidden argument gives the optional
5065 if (fsym && fsym->attr.optional && fsym->attr.value
5066 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5067 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5069 parmse.expr = fold_convert (gfc_sym_type (fsym),
5071 vec_safe_push (optionalargs, boolean_false_node);
5075 /* Pass a NULL pointer for an absent arg. */
5076 parmse.expr = null_pointer_node;
5077 if (arg->missing_arg_type == BT_CHARACTER)
5078 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5083 else if (arg->expr->expr_type == EXPR_NULL
5084 && fsym && !fsym->attr.pointer
5085 && (fsym->ts.type != BT_CLASS
5086 || !CLASS_DATA (fsym)->attr.class_pointer))
5088 /* Pass a NULL pointer to denote an absent arg. */
5089 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5090 && (fsym->ts.type != BT_CLASS
5091 || !CLASS_DATA (fsym)->attr.allocatable));
5092 gfc_init_se (&parmse, NULL);
5093 parmse.expr = null_pointer_node;
5094 if (arg->missing_arg_type == BT_CHARACTER)
5095 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5097 else if (fsym && fsym->ts.type == BT_CLASS
5098 && e->ts.type == BT_DERIVED)
5100 /* The derived type needs to be converted to a temporary
5102 gfc_init_se (&parmse, se);
5103 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5105 && e->expr_type == EXPR_VARIABLE
5106 && e->symtree->n.sym->attr.optional,
5107 CLASS_DATA (fsym)->attr.class_pointer
5108 || CLASS_DATA (fsym)->attr.allocatable);
5110 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5112 /* The intrinsic type needs to be converted to a temporary
5113 CLASS object for the unlimited polymorphic formal. */
5114 gfc_init_se (&parmse, se);
5115 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5117 else if (se->ss && se->ss->info->useflags)
5123 /* An elemental function inside a scalarized loop. */
5124 gfc_init_se (&parmse, se);
5125 parm_kind = ELEMENTAL;
5127 /* When no fsym is present, ulim_copy is set and this is a third or
5128 fourth argument, use call-by-value instead of by reference to
5129 hand the length properties to the copy routine (i.e., most of the
5130 time this will be a call to a __copy_character_* routine where the
5131 third and fourth arguments are the lengths of a deferred length
5133 if ((fsym && fsym->attr.value)
5134 || (ulim_copy && (argc == 2 || argc == 3)))
5135 gfc_conv_expr (&parmse, e);
5137 gfc_conv_expr_reference (&parmse, e);
5139 if (e->ts.type == BT_CHARACTER && !e->rank
5140 && e->expr_type == EXPR_FUNCTION)
5141 parmse.expr = build_fold_indirect_ref_loc (input_location,
5144 if (fsym && fsym->ts.type == BT_DERIVED
5145 && gfc_is_class_container_ref (e))
5147 parmse.expr = gfc_class_data_get (parmse.expr);
5149 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5150 && e->symtree->n.sym->attr.optional)
5152 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5153 parmse.expr = build3_loc (input_location, COND_EXPR,
5154 TREE_TYPE (parmse.expr),
5156 fold_convert (TREE_TYPE (parmse.expr),
5157 null_pointer_node));
5161 /* If we are passing an absent array as optional dummy to an
5162 elemental procedure, make sure that we pass NULL when the data
5163 pointer is NULL. We need this extra conditional because of
5164 scalarization which passes arrays elements to the procedure,
5165 ignoring the fact that the array can be absent/unallocated/... */
5166 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5168 tree descriptor_data;
5170 descriptor_data = ss->info->data.array.data;
5171 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5173 fold_convert (TREE_TYPE (descriptor_data),
5174 null_pointer_node));
5176 = fold_build3_loc (input_location, COND_EXPR,
5177 TREE_TYPE (parmse.expr),
5178 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5179 fold_convert (TREE_TYPE (parmse.expr),
5184 /* The scalarizer does not repackage the reference to a class
5185 array - instead it returns a pointer to the data element. */
5186 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5187 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5188 fsym->attr.intent != INTENT_IN
5189 && (CLASS_DATA (fsym)->attr.class_pointer
5190 || CLASS_DATA (fsym)->attr.allocatable),
5192 && e->expr_type == EXPR_VARIABLE
5193 && e->symtree->n.sym->attr.optional,
5194 CLASS_DATA (fsym)->attr.class_pointer
5195 || CLASS_DATA (fsym)->attr.allocatable);
5202 gfc_init_se (&parmse, NULL);
5204 /* Check whether the expression is a scalar or not; we cannot use
5205 e->rank as it can be nonzero for functions arguments. */
5206 argss = gfc_walk_expr (e);
5207 scalar = argss == gfc_ss_terminator;
5209 gfc_free_ss_chain (argss);
5211 /* Special handling for passing scalar polymorphic coarrays;
5212 otherwise one passes "class->_data.data" instead of "&class". */
5213 if (e->rank == 0 && e->ts.type == BT_CLASS
5214 && fsym && fsym->ts.type == BT_CLASS
5215 && CLASS_DATA (fsym)->attr.codimension
5216 && !CLASS_DATA (fsym)->attr.dimension)
5218 gfc_add_class_array_ref (e);
5219 parmse.want_coarray = 1;
5223 /* A scalar or transformational function. */
5226 if (e->expr_type == EXPR_VARIABLE
5227 && e->symtree->n.sym->attr.cray_pointee
5228 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5230 /* The Cray pointer needs to be converted to a pointer to
5231 a type given by the expression. */
5232 gfc_conv_expr (&parmse, e);
5233 type = build_pointer_type (TREE_TYPE (parmse.expr));
5234 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5235 parmse.expr = convert (type, tmp);
5237 else if (fsym && fsym->attr.value)
5239 if (fsym->ts.type == BT_CHARACTER
5240 && fsym->ts.is_c_interop
5241 && fsym->ns->proc_name != NULL
5242 && fsym->ns->proc_name->attr.is_bind_c)
5245 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5246 if (parmse.expr == NULL)
5247 gfc_conv_expr (&parmse, e);
5251 gfc_conv_expr (&parmse, e);
5252 if (fsym->attr.optional
5253 && fsym->ts.type != BT_CLASS
5254 && fsym->ts.type != BT_DERIVED)
5256 if (e->expr_type != EXPR_VARIABLE
5257 || !e->symtree->n.sym->attr.optional
5259 vec_safe_push (optionalargs, boolean_true_node);
5262 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5263 if (!e->symtree->n.sym->attr.value)
5265 = fold_build3_loc (input_location, COND_EXPR,
5266 TREE_TYPE (parmse.expr),
5268 fold_convert (TREE_TYPE (parmse.expr),
5269 integer_zero_node));
5271 vec_safe_push (optionalargs, tmp);
5276 else if (arg->name && arg->name[0] == '%')
5277 /* Argument list functions %VAL, %LOC and %REF are signalled
5278 through arg->name. */
5279 conv_arglist_function (&parmse, arg->expr, arg->name);
5280 else if ((e->expr_type == EXPR_FUNCTION)
5281 && ((e->value.function.esym
5282 && e->value.function.esym->result->attr.pointer)
5283 || (!e->value.function.esym
5284 && e->symtree->n.sym->attr.pointer))
5285 && fsym && fsym->attr.target)
5287 gfc_conv_expr (&parmse, e);
5288 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5290 else if (e->expr_type == EXPR_FUNCTION
5291 && e->symtree->n.sym->result
5292 && e->symtree->n.sym->result != e->symtree->n.sym
5293 && e->symtree->n.sym->result->attr.proc_pointer)
5295 /* Functions returning procedure pointers. */
5296 gfc_conv_expr (&parmse, e);
5297 if (fsym && fsym->attr.proc_pointer)
5298 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5302 if (e->ts.type == BT_CLASS && fsym
5303 && fsym->ts.type == BT_CLASS
5304 && (!CLASS_DATA (fsym)->as
5305 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5306 && CLASS_DATA (e)->attr.codimension)
5308 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5309 gcc_assert (!CLASS_DATA (fsym)->as);
5310 gfc_add_class_array_ref (e);
5311 parmse.want_coarray = 1;
5312 gfc_conv_expr_reference (&parmse, e);
5313 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5315 && e->expr_type == EXPR_VARIABLE);
5317 else if (e->ts.type == BT_CLASS && fsym
5318 && fsym->ts.type == BT_CLASS
5319 && !CLASS_DATA (fsym)->as
5320 && !CLASS_DATA (e)->as
5321 && strcmp (fsym->ts.u.derived->name,
5322 e->ts.u.derived->name))
5324 type = gfc_typenode_for_spec (&fsym->ts);
5325 var = gfc_create_var (type, fsym->name);
5326 gfc_conv_expr (&parmse, e);
5327 if (fsym->attr.optional
5328 && e->expr_type == EXPR_VARIABLE
5329 && e->symtree->n.sym->attr.optional)
5333 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5334 cond = fold_build2_loc (input_location, NE_EXPR,
5335 logical_type_node, tmp,
5336 fold_convert (TREE_TYPE (tmp),
5337 null_pointer_node));
5338 gfc_start_block (&block);
5339 gfc_add_modify (&block, var,
5340 fold_build1_loc (input_location,
5342 type, parmse.expr));
5343 gfc_add_expr_to_block (&parmse.pre,
5344 fold_build3_loc (input_location,
5345 COND_EXPR, void_type_node,
5346 cond, gfc_finish_block (&block),
5347 build_empty_stmt (input_location)));
5348 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5349 parmse.expr = build3_loc (input_location, COND_EXPR,
5350 TREE_TYPE (parmse.expr),
5352 fold_convert (TREE_TYPE (parmse.expr),
5353 null_pointer_node));
5357 /* Since the internal representation of unlimited
5358 polymorphic expressions includes an extra field
5359 that other class objects do not, a cast to the
5360 formal type does not work. */
5361 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5365 /* Set the _data field. */
5366 tmp = gfc_class_data_get (var);
5367 efield = fold_convert (TREE_TYPE (tmp),
5368 gfc_class_data_get (parmse.expr));
5369 gfc_add_modify (&parmse.pre, tmp, efield);
5371 /* Set the _vptr field. */
5372 tmp = gfc_class_vptr_get (var);
5373 efield = fold_convert (TREE_TYPE (tmp),
5374 gfc_class_vptr_get (parmse.expr));
5375 gfc_add_modify (&parmse.pre, tmp, efield);
5377 /* Set the _len field. */
5378 tmp = gfc_class_len_get (var);
5379 gfc_add_modify (&parmse.pre, tmp,
5380 build_int_cst (TREE_TYPE (tmp), 0));
5384 tmp = fold_build1_loc (input_location,
5387 gfc_add_modify (&parmse.pre, var, tmp);
5390 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5396 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5397 && !fsym->attr.allocatable && !fsym->attr.pointer
5398 && !e->symtree->n.sym->attr.dimension
5399 && !e->symtree->n.sym->attr.pointer
5401 && !e->symtree->n.sym->attr.dummy
5402 /* FIXME - PR 87395 and PR 41453 */
5403 && e->symtree->n.sym->attr.save == SAVE_NONE
5404 && !e->symtree->n.sym->attr.associate_var
5405 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5406 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5408 gfc_conv_expr_reference (&parmse, e, add_clobber);
5410 /* Catch base objects that are not variables. */
5411 if (e->ts.type == BT_CLASS
5412 && e->expr_type != EXPR_VARIABLE
5413 && expr && e == expr->base_expr)
5414 base_object = build_fold_indirect_ref_loc (input_location,
5417 /* A class array element needs converting back to be a
5418 class object, if the formal argument is a class object. */
5419 if (fsym && fsym->ts.type == BT_CLASS
5420 && e->ts.type == BT_CLASS
5421 && ((CLASS_DATA (fsym)->as
5422 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5423 || CLASS_DATA (e)->attr.dimension))
5424 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5425 fsym->attr.intent != INTENT_IN
5426 && (CLASS_DATA (fsym)->attr.class_pointer
5427 || CLASS_DATA (fsym)->attr.allocatable),
5429 && e->expr_type == EXPR_VARIABLE
5430 && e->symtree->n.sym->attr.optional,
5431 CLASS_DATA (fsym)->attr.class_pointer
5432 || CLASS_DATA (fsym)->attr.allocatable);
5434 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5435 allocated on entry, it must be deallocated. */
5436 if (fsym && fsym->attr.intent == INTENT_OUT
5437 && (fsym->attr.allocatable
5438 || (fsym->ts.type == BT_CLASS
5439 && CLASS_DATA (fsym)->attr.allocatable)))
5444 gfc_init_block (&block);
5446 if (e->ts.type == BT_CLASS)
5447 ptr = gfc_class_data_get (ptr);
5449 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5452 gfc_add_expr_to_block (&block, tmp);
5453 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5454 void_type_node, ptr,
5456 gfc_add_expr_to_block (&block, tmp);
5458 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5460 gfc_add_modify (&block, ptr,
5461 fold_convert (TREE_TYPE (ptr),
5462 null_pointer_node));
5463 gfc_add_expr_to_block (&block, tmp);
5465 else if (fsym->ts.type == BT_CLASS)
5468 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5469 tmp = gfc_get_symbol_decl (vtab);
5470 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5471 ptr = gfc_class_vptr_get (parmse.expr);
5472 gfc_add_modify (&block, ptr,
5473 fold_convert (TREE_TYPE (ptr), tmp));
5474 gfc_add_expr_to_block (&block, tmp);
5477 if (fsym->attr.optional
5478 && e->expr_type == EXPR_VARIABLE
5479 && e->symtree->n.sym->attr.optional)
5481 tmp = fold_build3_loc (input_location, COND_EXPR,
5483 gfc_conv_expr_present (e->symtree->n.sym),
5484 gfc_finish_block (&block),
5485 build_empty_stmt (input_location));
5488 tmp = gfc_finish_block (&block);
5490 gfc_add_expr_to_block (&se->pre, tmp);
5493 if (fsym && (fsym->ts.type == BT_DERIVED
5494 || fsym->ts.type == BT_ASSUMED)
5495 && e->ts.type == BT_CLASS
5496 && !CLASS_DATA (e)->attr.dimension
5497 && !CLASS_DATA (e)->attr.codimension)
5499 parmse.expr = gfc_class_data_get (parmse.expr);
5500 /* The result is a class temporary, whose _data component
5501 must be freed to avoid a memory leak. */
5502 if (e->expr_type == EXPR_FUNCTION
5503 && CLASS_DATA (e)->attr.allocatable)
5509 /* Borrow the function symbol to make a call to
5510 gfc_add_finalizer_call and then restore it. */
5511 tmp = e->symtree->n.sym->backend_decl;
5512 e->symtree->n.sym->backend_decl
5513 = TREE_OPERAND (parmse.expr, 0);
5514 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5515 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5516 finalized = gfc_add_finalizer_call (&parmse.post,
5518 gfc_free_expr (var);
5519 e->symtree->n.sym->backend_decl = tmp;
5520 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5522 /* Then free the class _data. */
5523 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5524 tmp = fold_build2_loc (input_location, NE_EXPR,
5527 tmp = build3_v (COND_EXPR, tmp,
5528 gfc_call_free (parmse.expr),
5529 build_empty_stmt (input_location));
5530 gfc_add_expr_to_block (&parmse.post, tmp);
5531 gfc_add_modify (&parmse.post, parmse.expr, zero);
5535 /* Wrap scalar variable in a descriptor. We need to convert
5536 the address of a pointer back to the pointer itself before,
5537 we can assign it to the data field. */
5539 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5540 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5543 if (TREE_CODE (tmp) == ADDR_EXPR)
5544 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5545 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5547 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5550 else if (fsym && e->expr_type != EXPR_NULL
5551 && ((fsym->attr.pointer
5552 && fsym->attr.flavor != FL_PROCEDURE)
5553 || (fsym->attr.proc_pointer
5554 && !(e->expr_type == EXPR_VARIABLE
5555 && e->symtree->n.sym->attr.dummy))
5556 || (fsym->attr.proc_pointer
5557 && e->expr_type == EXPR_VARIABLE
5558 && gfc_is_proc_ptr_comp (e))
5559 || (fsym->attr.allocatable
5560 && fsym->attr.flavor != FL_PROCEDURE)))
5562 /* Scalar pointer dummy args require an extra level of
5563 indirection. The null pointer already contains
5564 this level of indirection. */
5565 parm_kind = SCALAR_POINTER;
5566 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5570 else if (e->ts.type == BT_CLASS
5571 && fsym && fsym->ts.type == BT_CLASS
5572 && (CLASS_DATA (fsym)->attr.dimension
5573 || CLASS_DATA (fsym)->attr.codimension))
5575 /* Pass a class array. */
5576 parmse.use_offset = 1;
5577 gfc_conv_expr_descriptor (&parmse, e);
5579 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5580 allocated on entry, it must be deallocated. */
5581 if (fsym->attr.intent == INTENT_OUT
5582 && CLASS_DATA (fsym)->attr.allocatable)
5587 gfc_init_block (&block);
5589 ptr = gfc_class_data_get (ptr);
5591 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5592 NULL_TREE, NULL_TREE,
5594 GFC_CAF_COARRAY_NOCOARRAY);
5595 gfc_add_expr_to_block (&block, tmp);
5596 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5597 void_type_node, ptr,
5599 gfc_add_expr_to_block (&block, tmp);
5600 gfc_reset_vptr (&block, e);
5602 if (fsym->attr.optional
5603 && e->expr_type == EXPR_VARIABLE
5605 || (e->ref->type == REF_ARRAY
5606 && e->ref->u.ar.type != AR_FULL))
5607 && e->symtree->n.sym->attr.optional)
5609 tmp = fold_build3_loc (input_location, COND_EXPR,
5611 gfc_conv_expr_present (e->symtree->n.sym),
5612 gfc_finish_block (&block),
5613 build_empty_stmt (input_location));
5616 tmp = gfc_finish_block (&block);
5618 gfc_add_expr_to_block (&se->pre, tmp);
5621 /* The conversion does not repackage the reference to a class
5622 array - _data descriptor. */
5623 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5624 fsym->attr.intent != INTENT_IN
5625 && (CLASS_DATA (fsym)->attr.class_pointer
5626 || CLASS_DATA (fsym)->attr.allocatable),
5628 && e->expr_type == EXPR_VARIABLE
5629 && e->symtree->n.sym->attr.optional,
5630 CLASS_DATA (fsym)->attr.class_pointer
5631 || CLASS_DATA (fsym)->attr.allocatable);
5635 /* If the argument is a function call that may not create
5636 a temporary for the result, we have to check that we
5637 can do it, i.e. that there is no alias between this
5638 argument and another one. */
5639 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5645 intent = fsym->attr.intent;
5647 intent = INTENT_UNKNOWN;
5649 if (gfc_check_fncall_dependency (e, intent, sym, args,
5651 parmse.force_tmp = 1;
5653 iarg = e->value.function.actual->expr;
5655 /* Temporary needed if aliasing due to host association. */
5656 if (sym->attr.contained
5658 && !sym->attr.implicit_pure
5659 && !sym->attr.use_assoc
5660 && iarg->expr_type == EXPR_VARIABLE
5661 && sym->ns == iarg->symtree->n.sym->ns)
5662 parmse.force_tmp = 1;
5664 /* Ditto within module. */
5665 if (sym->attr.use_assoc
5667 && !sym->attr.implicit_pure
5668 && iarg->expr_type == EXPR_VARIABLE
5669 && sym->module == iarg->symtree->n.sym->module)
5670 parmse.force_tmp = 1;
5673 if (e->expr_type == EXPR_VARIABLE
5674 && is_subref_array (e)
5675 && !(fsym && fsym->attr.pointer))
5676 /* The actual argument is a component reference to an
5677 array of derived types. In this case, the argument
5678 is converted to a temporary, which is passed and then
5679 written back after the procedure call. */
5680 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5681 fsym ? fsym->attr.intent : INTENT_INOUT,
5682 fsym && fsym->attr.pointer);
5683 else if (gfc_is_class_array_ref (e, NULL)
5684 && fsym && fsym->ts.type == BT_DERIVED)
5685 /* The actual argument is a component reference to an
5686 array of derived types. In this case, the argument
5687 is converted to a temporary, which is passed and then
5688 written back after the procedure call.
5689 OOP-TODO: Insert code so that if the dynamic type is
5690 the same as the declared type, copy-in/copy-out does
5692 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5693 fsym ? fsym->attr.intent : INTENT_INOUT,
5694 fsym && fsym->attr.pointer);
5696 else if (gfc_is_class_array_function (e)
5697 && fsym && fsym->ts.type == BT_DERIVED)
5698 /* See previous comment. For function actual argument,
5699 the write out is not needed so the intent is set as
5702 e->must_finalize = 1;
5703 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5705 fsym && fsym->attr.pointer);
5708 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5711 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5712 allocated on entry, it must be deallocated. */
5713 if (fsym && fsym->attr.allocatable
5714 && fsym->attr.intent == INTENT_OUT)
5716 if (fsym->ts.type == BT_DERIVED
5717 && fsym->ts.u.derived->attr.alloc_comp)
5719 // deallocate the components first
5720 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5721 parmse.expr, e->rank);
5722 if (tmp != NULL_TREE)
5723 gfc_add_expr_to_block (&se->pre, tmp);
5726 tmp = build_fold_indirect_ref_loc (input_location,
5728 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5729 tmp = gfc_conv_descriptor_data_get (tmp);
5730 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5731 NULL_TREE, NULL_TREE, true,
5733 GFC_CAF_COARRAY_NOCOARRAY);
5734 if (fsym->attr.optional
5735 && e->expr_type == EXPR_VARIABLE
5736 && e->symtree->n.sym->attr.optional)
5737 tmp = fold_build3_loc (input_location, COND_EXPR,
5739 gfc_conv_expr_present (e->symtree->n.sym),
5740 tmp, build_empty_stmt (input_location));
5741 gfc_add_expr_to_block (&se->pre, tmp);
5746 /* The case with fsym->attr.optional is that of a user subroutine
5747 with an interface indicating an optional argument. When we call
5748 an intrinsic subroutine, however, fsym is NULL, but we might still
5749 have an optional argument, so we proceed to the substitution
5751 if (e && (fsym == NULL || fsym->attr.optional))
5753 /* If an optional argument is itself an optional dummy argument,
5754 check its presence and substitute a null if absent. This is
5755 only needed when passing an array to an elemental procedure
5756 as then array elements are accessed - or no NULL pointer is
5757 allowed and a "1" or "0" should be passed if not present.
5758 When passing a non-array-descriptor full array to a
5759 non-array-descriptor dummy, no check is needed. For
5760 array-descriptor actual to array-descriptor dummy, see
5761 PR 41911 for why a check has to be inserted.
5762 fsym == NULL is checked as intrinsics required the descriptor
5763 but do not always set fsym.
5764 Also, it is necessary to pass a NULL pointer to library routines
5765 which usually ignore optional arguments, so they can handle
5766 these themselves. */
5767 if (e->expr_type == EXPR_VARIABLE
5768 && e->symtree->n.sym->attr.optional
5769 && (((e->rank != 0 && elemental_proc)
5770 || e->representation.length || e->ts.type == BT_CHARACTER
5774 && (fsym->as->type == AS_ASSUMED_SHAPE
5775 || fsym->as->type == AS_ASSUMED_RANK
5776 || fsym->as->type == AS_DEFERRED)))))
5777 || se->ignore_optional))
5778 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5779 e->representation.length);
5784 /* Obtain the character length of an assumed character length
5785 length procedure from the typespec. */
5786 if (fsym->ts.type == BT_CHARACTER
5787 && parmse.string_length == NULL_TREE
5788 && e->ts.type == BT_PROCEDURE
5789 && e->symtree->n.sym->ts.type == BT_CHARACTER
5790 && e->symtree->n.sym->ts.u.cl->length != NULL
5791 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5793 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5794 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5798 if (fsym && need_interface_mapping && e)
5799 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5801 gfc_add_block_to_block (&se->pre, &parmse.pre);
5802 gfc_add_block_to_block (&post, &parmse.post);
5804 /* Allocated allocatable components of derived types must be
5805 deallocated for non-variable scalars, array arguments to elemental
5806 procedures, and array arguments with descriptor to non-elemental
5807 procedures. As bounds information for descriptorless arrays is no
5808 longer available here, they are dealt with in trans-array.c
5809 (gfc_conv_array_parameter). */
5810 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5811 && e->ts.u.derived->attr.alloc_comp
5812 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5813 && !expr_may_alias_variables (e, elemental_proc))
5816 /* It is known the e returns a structure type with at least one
5817 allocatable component. When e is a function, ensure that the
5818 function is called once only by using a temporary variable. */
5819 if (!DECL_P (parmse.expr))
5820 parmse.expr = gfc_evaluate_now_loc (input_location,
5821 parmse.expr, &se->pre);
5823 if (fsym && fsym->attr.value)
5826 tmp = build_fold_indirect_ref_loc (input_location,
5829 parm_rank = e->rank;
5837 case (SCALAR_POINTER):
5838 tmp = build_fold_indirect_ref_loc (input_location,
5843 if (e->expr_type == EXPR_OP
5844 && e->value.op.op == INTRINSIC_PARENTHESES
5845 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5848 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5849 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5851 gfc_add_expr_to_block (&se->post, local_tmp);
5854 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5856 /* The derived type is passed to gfc_deallocate_alloc_comp.
5857 Therefore, class actuals can handled correctly but derived
5858 types passed to class formals need the _data component. */
5859 tmp = gfc_class_data_get (tmp);
5860 if (!CLASS_DATA (fsym)->attr.dimension)
5861 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5864 if (!finalized && !e->must_finalize)
5866 if ((e->ts.type == BT_CLASS
5867 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
5868 || e->ts.type == BT_DERIVED)
5869 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
5871 else if (e->ts.type == BT_CLASS)
5872 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
5874 gfc_prepend_expr_to_block (&post, tmp);
5878 /* Add argument checking of passing an unallocated/NULL actual to
5879 a nonallocatable/nonpointer dummy. */
5881 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5883 symbol_attribute attr;
5887 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5888 attr = gfc_expr_attr (e);
5890 goto end_pointer_check;
5892 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5893 allocatable to an optional dummy, cf. 12.5.2.12. */
5894 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5895 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5896 goto end_pointer_check;
5900 /* If the actual argument is an optional pointer/allocatable and
5901 the formal argument takes an nonpointer optional value,
5902 it is invalid to pass a non-present argument on, even
5903 though there is no technical reason for this in gfortran.
5904 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5905 tree present, null_ptr, type;
5907 if (attr.allocatable
5908 && (fsym == NULL || !fsym->attr.allocatable))
5909 msg = xasprintf ("Allocatable actual argument '%s' is not "
5910 "allocated or not present",
5911 e->symtree->n.sym->name);
5912 else if (attr.pointer
5913 && (fsym == NULL || !fsym->attr.pointer))
5914 msg = xasprintf ("Pointer actual argument '%s' is not "
5915 "associated or not present",
5916 e->symtree->n.sym->name);
5917 else if (attr.proc_pointer
5918 && (fsym == NULL || !fsym->attr.proc_pointer))
5919 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5920 "associated or not present",
5921 e->symtree->n.sym->name);
5923 goto end_pointer_check;
5925 present = gfc_conv_expr_present (e->symtree->n.sym);
5926 type = TREE_TYPE (present);
5927 present = fold_build2_loc (input_location, EQ_EXPR,
5928 logical_type_node, present,
5930 null_pointer_node));
5931 type = TREE_TYPE (parmse.expr);
5932 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5933 logical_type_node, parmse.expr,
5935 null_pointer_node));
5936 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5937 logical_type_node, present, null_ptr);
5941 if (attr.allocatable
5942 && (fsym == NULL || !fsym->attr.allocatable))
5943 msg = xasprintf ("Allocatable actual argument '%s' is not "
5944 "allocated", e->symtree->n.sym->name);
5945 else if (attr.pointer
5946 && (fsym == NULL || !fsym->attr.pointer))
5947 msg = xasprintf ("Pointer actual argument '%s' is not "
5948 "associated", e->symtree->n.sym->name);
5949 else if (attr.proc_pointer
5950 && (fsym == NULL || !fsym->attr.proc_pointer))
5951 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5952 "associated", e->symtree->n.sym->name);
5954 goto end_pointer_check;
5958 /* If the argument is passed by value, we need to strip the
5960 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5961 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5963 cond = fold_build2_loc (input_location, EQ_EXPR,
5964 logical_type_node, tmp,
5965 fold_convert (TREE_TYPE (tmp),
5966 null_pointer_node));
5969 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5975 /* Deferred length dummies pass the character length by reference
5976 so that the value can be returned. */
5977 if (parmse.string_length && fsym && fsym->ts.deferred)
5979 if (INDIRECT_REF_P (parmse.string_length))
5980 /* In chains of functions/procedure calls the string_length already
5981 is a pointer to the variable holding the length. Therefore
5982 remove the deref on call. */
5983 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5986 tmp = parmse.string_length;
5987 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5988 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5989 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5993 /* Character strings are passed as two parameters, a length and a
5994 pointer - except for Bind(c) which only passes the pointer.
5995 An unlimited polymorphic formal argument likewise does not
5997 if (parmse.string_length != NULL_TREE
5998 && !sym->attr.is_bind_c
5999 && !(fsym && UNLIMITED_POLY (fsym)))
6000 vec_safe_push (stringargs, parmse.string_length);
6002 /* When calling __copy for character expressions to unlimited
6003 polymorphic entities, the dst argument needs a string length. */
6004 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6005 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6006 && arg->next && arg->next->expr
6007 && (arg->next->expr->ts.type == BT_DERIVED
6008 || arg->next->expr->ts.type == BT_CLASS)
6009 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6010 vec_safe_push (stringargs, parmse.string_length);
6012 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6013 pass the token and the offset as additional arguments. */
6014 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6015 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6016 && !fsym->attr.allocatable)
6017 || (fsym->ts.type == BT_CLASS
6018 && CLASS_DATA (fsym)->attr.codimension
6019 && !CLASS_DATA (fsym)->attr.allocatable)))
6021 /* Token and offset. */
6022 vec_safe_push (stringargs, null_pointer_node);
6023 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6024 gcc_assert (fsym->attr.optional);
6026 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6027 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6028 && !fsym->attr.allocatable)
6029 || (fsym->ts.type == BT_CLASS
6030 && CLASS_DATA (fsym)->attr.codimension
6031 && !CLASS_DATA (fsym)->attr.allocatable)))
6033 tree caf_decl, caf_type;
6036 caf_decl = gfc_get_tree_for_caf_expr (e);
6037 caf_type = TREE_TYPE (caf_decl);
6039 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6040 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6041 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6042 tmp = gfc_conv_descriptor_token (caf_decl);
6043 else if (DECL_LANG_SPECIFIC (caf_decl)
6044 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6045 tmp = GFC_DECL_TOKEN (caf_decl);
6048 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6049 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6050 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6053 vec_safe_push (stringargs, tmp);
6055 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6056 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6057 offset = build_int_cst (gfc_array_index_type, 0);
6058 else if (DECL_LANG_SPECIFIC (caf_decl)
6059 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6060 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6061 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6062 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6064 offset = build_int_cst (gfc_array_index_type, 0);
6066 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6067 tmp = gfc_conv_descriptor_data_get (caf_decl);
6070 gcc_assert (POINTER_TYPE_P (caf_type));
6074 tmp2 = fsym->ts.type == BT_CLASS
6075 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6076 if ((fsym->ts.type != BT_CLASS
6077 && (fsym->as->type == AS_ASSUMED_SHAPE
6078 || fsym->as->type == AS_ASSUMED_RANK))
6079 || (fsym->ts.type == BT_CLASS
6080 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6081 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6083 if (fsym->ts.type == BT_CLASS)
6084 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6087 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6088 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6090 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6091 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6093 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6094 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6097 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6100 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6101 gfc_array_index_type,
6102 fold_convert (gfc_array_index_type, tmp2),
6103 fold_convert (gfc_array_index_type, tmp));
6104 offset = fold_build2_loc (input_location, PLUS_EXPR,
6105 gfc_array_index_type, offset, tmp);
6107 vec_safe_push (stringargs, offset);
6110 vec_safe_push (arglist, parmse.expr);
6112 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6116 else if (sym->ts.type == BT_CLASS)
6117 ts = CLASS_DATA (sym)->ts;
6121 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6122 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6123 else if (ts.type == BT_CHARACTER)
6125 if (ts.u.cl->length == NULL)
6127 /* Assumed character length results are not allowed by C418 of the 2003
6128 standard and are trapped in resolve.c; except in the case of SPREAD
6129 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6130 we take the character length of the first argument for the result.
6131 For dummies, we have to look through the formal argument list for
6132 this function and use the character length found there.*/
6134 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6135 else if (!sym->attr.dummy)
6136 cl.backend_decl = (*stringargs)[0];
6139 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6140 for (; formal; formal = formal->next)
6141 if (strcmp (formal->sym->name, sym->name) == 0)
6142 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6144 len = cl.backend_decl;
6150 /* Calculate the length of the returned string. */
6151 gfc_init_se (&parmse, NULL);
6152 if (need_interface_mapping)
6153 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6155 gfc_conv_expr (&parmse, ts.u.cl->length);
6156 gfc_add_block_to_block (&se->pre, &parmse.pre);
6157 gfc_add_block_to_block (&se->post, &parmse.post);
6159 /* TODO: It would be better to have the charlens as
6160 gfc_charlen_type_node already when the interface is
6161 created instead of converting it here (see PR 84615). */
6162 tmp = fold_build2_loc (input_location, MAX_EXPR,
6163 gfc_charlen_type_node,
6164 fold_convert (gfc_charlen_type_node, tmp),
6165 build_zero_cst (gfc_charlen_type_node));
6166 cl.backend_decl = tmp;
6169 /* Set up a charlen structure for it. */
6174 len = cl.backend_decl;
6177 byref = (comp && (comp->attr.dimension
6178 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6179 || (!comp && gfc_return_by_reference (sym));
6182 if (se->direct_byref)
6184 /* Sometimes, too much indirection can be applied; e.g. for
6185 function_result = array_valued_recursive_function. */
6186 if (TREE_TYPE (TREE_TYPE (se->expr))
6187 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6188 && GFC_DESCRIPTOR_TYPE_P
6189 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6190 se->expr = build_fold_indirect_ref_loc (input_location,
6193 /* If the lhs of an assignment x = f(..) is allocatable and
6194 f2003 is allowed, we must do the automatic reallocation.
6195 TODO - deal with intrinsics, without using a temporary. */
6196 if (flag_realloc_lhs
6197 && se->ss && se->ss->loop_chain
6198 && se->ss->loop_chain->is_alloc_lhs
6199 && !expr->value.function.isym
6200 && sym->result->as != NULL)
6202 /* Evaluate the bounds of the result, if known. */
6203 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6206 /* Perform the automatic reallocation. */
6207 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6209 gfc_add_expr_to_block (&se->pre, tmp);
6211 /* Pass the temporary as the first argument. */
6212 result = info->descriptor;
6215 result = build_fold_indirect_ref_loc (input_location,
6217 vec_safe_push (retargs, se->expr);
6219 else if (comp && comp->attr.dimension)
6221 gcc_assert (se->loop && info);
6223 /* Set the type of the array. */
6224 tmp = gfc_typenode_for_spec (&comp->ts);
6225 gcc_assert (se->ss->dimen == se->loop->dimen);
6227 /* Evaluate the bounds of the result, if known. */
6228 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6230 /* If the lhs of an assignment x = f(..) is allocatable and
6231 f2003 is allowed, we must not generate the function call
6232 here but should just send back the results of the mapping.
6233 This is signalled by the function ss being flagged. */
6234 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6236 gfc_free_interface_mapping (&mapping);
6237 return has_alternate_specifier;
6240 /* Create a temporary to store the result. In case the function
6241 returns a pointer, the temporary will be a shallow copy and
6242 mustn't be deallocated. */
6243 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6244 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6245 tmp, NULL_TREE, false,
6246 !comp->attr.pointer, callee_alloc,
6247 &se->ss->info->expr->where);
6249 /* Pass the temporary as the first argument. */
6250 result = info->descriptor;
6251 tmp = gfc_build_addr_expr (NULL_TREE, result);
6252 vec_safe_push (retargs, tmp);
6254 else if (!comp && sym->result->attr.dimension)
6256 gcc_assert (se->loop && info);
6258 /* Set the type of the array. */
6259 tmp = gfc_typenode_for_spec (&ts);
6260 gcc_assert (se->ss->dimen == se->loop->dimen);
6262 /* Evaluate the bounds of the result, if known. */
6263 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6265 /* If the lhs of an assignment x = f(..) is allocatable and
6266 f2003 is allowed, we must not generate the function call
6267 here but should just send back the results of the mapping.
6268 This is signalled by the function ss being flagged. */
6269 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6271 gfc_free_interface_mapping (&mapping);
6272 return has_alternate_specifier;
6275 /* Create a temporary to store the result. In case the function
6276 returns a pointer, the temporary will be a shallow copy and
6277 mustn't be deallocated. */
6278 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6279 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6280 tmp, NULL_TREE, false,
6281 !sym->attr.pointer, callee_alloc,
6282 &se->ss->info->expr->where);
6284 /* Pass the temporary as the first argument. */
6285 result = info->descriptor;
6286 tmp = gfc_build_addr_expr (NULL_TREE, result);
6287 vec_safe_push (retargs, tmp);
6289 else if (ts.type == BT_CHARACTER)
6291 /* Pass the string length. */
6292 type = gfc_get_character_type (ts.kind, ts.u.cl);
6293 type = build_pointer_type (type);
6295 /* Emit a DECL_EXPR for the VLA type. */
6296 tmp = TREE_TYPE (type);
6298 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6300 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6301 DECL_ARTIFICIAL (tmp) = 1;
6302 DECL_IGNORED_P (tmp) = 1;
6303 tmp = fold_build1_loc (input_location, DECL_EXPR,
6304 TREE_TYPE (tmp), tmp);
6305 gfc_add_expr_to_block (&se->pre, tmp);
6308 /* Return an address to a char[0:len-1]* temporary for
6309 character pointers. */
6310 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6311 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6313 var = gfc_create_var (type, "pstr");
6315 if ((!comp && sym->attr.allocatable)
6316 || (comp && comp->attr.allocatable))
6318 gfc_add_modify (&se->pre, var,
6319 fold_convert (TREE_TYPE (var),
6320 null_pointer_node));
6321 tmp = gfc_call_free (var);
6322 gfc_add_expr_to_block (&se->post, tmp);
6325 /* Provide an address expression for the function arguments. */
6326 var = gfc_build_addr_expr (NULL_TREE, var);
6329 var = gfc_conv_string_tmp (se, type, len);
6331 vec_safe_push (retargs, var);
6335 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6337 type = gfc_get_complex_type (ts.kind);
6338 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6339 vec_safe_push (retargs, var);
6342 /* Add the string length to the argument list. */
6343 if (ts.type == BT_CHARACTER && ts.deferred)
6347 tmp = gfc_evaluate_now (len, &se->pre);
6348 TREE_STATIC (tmp) = 1;
6349 gfc_add_modify (&se->pre, tmp,
6350 build_int_cst (TREE_TYPE (tmp), 0));
6351 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6352 vec_safe_push (retargs, tmp);
6354 else if (ts.type == BT_CHARACTER)
6355 vec_safe_push (retargs, len);
6357 gfc_free_interface_mapping (&mapping);
6359 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6360 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6361 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6362 vec_safe_reserve (retargs, arglen);
6364 /* Add the return arguments. */
6365 vec_safe_splice (retargs, arglist);
6367 /* Add the hidden present status for optional+value to the arguments. */
6368 vec_safe_splice (retargs, optionalargs);
6370 /* Add the hidden string length parameters to the arguments. */
6371 vec_safe_splice (retargs, stringargs);
6373 /* We may want to append extra arguments here. This is used e.g. for
6374 calls to libgfortran_matmul_??, which need extra information. */
6375 vec_safe_splice (retargs, append_args);
6379 /* Generate the actual call. */
6380 if (base_object == NULL_TREE)
6381 conv_function_val (se, sym, expr);
6383 conv_base_obj_fcn_val (se, base_object, expr);
6385 /* If there are alternate return labels, function type should be
6386 integer. Can't modify the type in place though, since it can be shared
6387 with other functions. For dummy arguments, the typing is done to
6388 this result, even if it has to be repeated for each call. */
6389 if (has_alternate_specifier
6390 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6392 if (!sym->attr.dummy)
6394 TREE_TYPE (sym->backend_decl)
6395 = build_function_type (integer_type_node,
6396 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6397 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6400 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6403 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6404 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6406 /* Allocatable scalar function results must be freed and nullified
6407 after use. This necessitates the creation of a temporary to
6408 hold the result to prevent duplicate calls. */
6409 if (!byref && sym->ts.type != BT_CHARACTER
6410 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6411 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6413 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6414 gfc_add_modify (&se->pre, tmp, se->expr);
6416 tmp = gfc_call_free (tmp);
6417 gfc_add_expr_to_block (&post, tmp);
6418 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6421 /* If we have a pointer function, but we don't want a pointer, e.g.
6424 where f is pointer valued, we have to dereference the result. */
6425 if (!se->want_pointer && !byref
6426 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6427 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6428 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6430 /* f2c calling conventions require a scalar default real function to
6431 return a double precision result. Convert this back to default
6432 real. We only care about the cases that can happen in Fortran 77.
6434 if (flag_f2c && sym->ts.type == BT_REAL
6435 && sym->ts.kind == gfc_default_real_kind
6436 && !sym->attr.always_explicit)
6437 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6439 /* A pure function may still have side-effects - it may modify its
6441 TREE_SIDE_EFFECTS (se->expr) = 1;
6443 if (!sym->attr.pure)
6444 TREE_SIDE_EFFECTS (se->expr) = 1;
6449 /* Add the function call to the pre chain. There is no expression. */
6450 gfc_add_expr_to_block (&se->pre, se->expr);
6451 se->expr = NULL_TREE;
6453 if (!se->direct_byref)
6455 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6457 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6459 /* Check the data pointer hasn't been modified. This would
6460 happen in a function returning a pointer. */
6461 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6462 tmp = fold_build2_loc (input_location, NE_EXPR,
6465 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6468 se->expr = info->descriptor;
6469 /* Bundle in the string length. */
6470 se->string_length = len;
6472 else if (ts.type == BT_CHARACTER)
6474 /* Dereference for character pointer results. */
6475 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6476 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6477 se->expr = build_fold_indirect_ref_loc (input_location, var);
6481 se->string_length = len;
6485 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6486 se->expr = build_fold_indirect_ref_loc (input_location, var);
6491 /* Associate the rhs class object's meta-data with the result, when the
6492 result is a temporary. */
6493 if (args && args->expr && args->expr->ts.type == BT_CLASS
6494 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6495 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6498 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6500 gfc_init_se (&parmse, NULL);
6501 parmse.data_not_needed = 1;
6502 gfc_conv_expr (&parmse, class_expr);
6503 if (!DECL_LANG_SPECIFIC (result))
6504 gfc_allocate_lang_decl (result);
6505 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6506 gfc_free_expr (class_expr);
6507 gcc_assert (parmse.pre.head == NULL_TREE
6508 && parmse.post.head == NULL_TREE);
6511 /* Follow the function call with the argument post block. */
6514 gfc_add_block_to_block (&se->pre, &post);
6516 /* Transformational functions of derived types with allocatable
6517 components must have the result allocatable components copied when the
6518 argument is actually given. */
6519 arg = expr->value.function.actual;
6520 if (result && arg && expr->rank
6521 && expr->value.function.isym
6522 && expr->value.function.isym->transformational
6524 && arg->expr->ts.type == BT_DERIVED
6525 && arg->expr->ts.u.derived->attr.alloc_comp)
6528 /* Copy the allocatable components. We have to use a
6529 temporary here to prevent source allocatable components
6530 from being corrupted. */
6531 tmp2 = gfc_evaluate_now (result, &se->pre);
6532 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6533 result, tmp2, expr->rank, 0);
6534 gfc_add_expr_to_block (&se->pre, tmp);
6535 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6537 gfc_add_expr_to_block (&se->pre, tmp);
6539 /* Finally free the temporary's data field. */
6540 tmp = gfc_conv_descriptor_data_get (tmp2);
6541 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6542 NULL_TREE, NULL_TREE, true,
6543 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6544 gfc_add_expr_to_block (&se->pre, tmp);
6549 /* For a function with a class array result, save the result as
6550 a temporary, set the info fields needed by the scalarizer and
6551 call the finalization function of the temporary. Note that the
6552 nullification of allocatable components needed by the result
6553 is done in gfc_trans_assignment_1. */
6554 if (expr && ((gfc_is_class_array_function (expr)
6555 && se->ss && se->ss->loop)
6556 || gfc_is_alloc_class_scalar_function (expr))
6557 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6558 && expr->must_finalize)
6563 if (se->ss && se->ss->loop)
6565 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6566 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6567 tmp = gfc_class_data_get (se->expr);
6568 info->descriptor = tmp;
6569 info->data = gfc_conv_descriptor_data_get (tmp);
6570 info->offset = gfc_conv_descriptor_offset_get (tmp);
6571 for (n = 0; n < se->ss->loop->dimen; n++)
6573 tree dim = gfc_rank_cst[n];
6574 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6575 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6580 /* TODO Eliminate the doubling of temporaries. This
6581 one is necessary to ensure no memory leakage. */
6582 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6583 tmp = gfc_class_data_get (se->expr);
6584 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6585 CLASS_DATA (expr->value.function.esym->result)->attr);
6588 if ((gfc_is_class_array_function (expr)
6589 || gfc_is_alloc_class_scalar_function (expr))
6590 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6591 goto no_finalization;
6593 final_fndecl = gfc_class_vtab_final_get (se->expr);
6594 is_final = fold_build2_loc (input_location, NE_EXPR,
6597 fold_convert (TREE_TYPE (final_fndecl),
6598 null_pointer_node));
6599 final_fndecl = build_fold_indirect_ref_loc (input_location,
6601 tmp = build_call_expr_loc (input_location,
6603 gfc_build_addr_expr (NULL, tmp),
6604 gfc_class_vtab_size_get (se->expr),
6605 boolean_false_node);
6606 tmp = fold_build3_loc (input_location, COND_EXPR,
6607 void_type_node, is_final, tmp,
6608 build_empty_stmt (input_location));
6610 if (se->ss && se->ss->loop)
6612 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6613 tmp = fold_build2_loc (input_location, NE_EXPR,
6616 fold_convert (TREE_TYPE (info->data),
6617 null_pointer_node));
6618 tmp = fold_build3_loc (input_location, COND_EXPR,
6619 void_type_node, tmp,
6620 gfc_call_free (info->data),
6621 build_empty_stmt (input_location));
6622 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6627 gfc_prepend_expr_to_block (&se->post, tmp);
6628 classdata = gfc_class_data_get (se->expr);
6629 tmp = fold_build2_loc (input_location, NE_EXPR,
6632 fold_convert (TREE_TYPE (classdata),
6633 null_pointer_node));
6634 tmp = fold_build3_loc (input_location, COND_EXPR,
6635 void_type_node, tmp,
6636 gfc_call_free (classdata),
6637 build_empty_stmt (input_location));
6638 gfc_add_expr_to_block (&se->post, tmp);
6643 gfc_add_block_to_block (&se->post, &post);
6646 return has_alternate_specifier;
6650 /* Fill a character string with spaces. */
6653 fill_with_spaces (tree start, tree type, tree size)
6655 stmtblock_t block, loop;
6656 tree i, el, exit_label, cond, tmp;
6658 /* For a simple char type, we can call memset(). */
6659 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6660 return build_call_expr_loc (input_location,
6661 builtin_decl_explicit (BUILT_IN_MEMSET),
6663 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6664 lang_hooks.to_target_charset (' ')),
6665 fold_convert (size_type_node, size));
6667 /* Otherwise, we use a loop:
6668 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6672 /* Initialize variables. */
6673 gfc_init_block (&block);
6674 i = gfc_create_var (sizetype, "i");
6675 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6676 el = gfc_create_var (build_pointer_type (type), "el");
6677 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6678 exit_label = gfc_build_label_decl (NULL_TREE);
6679 TREE_USED (exit_label) = 1;
6683 gfc_init_block (&loop);
6685 /* Exit condition. */
6686 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6687 build_zero_cst (sizetype));
6688 tmp = build1_v (GOTO_EXPR, exit_label);
6689 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6690 build_empty_stmt (input_location));
6691 gfc_add_expr_to_block (&loop, tmp);
6694 gfc_add_modify (&loop,
6695 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6696 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6698 /* Increment loop variables. */
6699 gfc_add_modify (&loop, i,
6700 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6701 TYPE_SIZE_UNIT (type)));
6702 gfc_add_modify (&loop, el,
6703 fold_build_pointer_plus_loc (input_location,
6704 el, TYPE_SIZE_UNIT (type)));
6706 /* Making the loop... actually loop! */
6707 tmp = gfc_finish_block (&loop);
6708 tmp = build1_v (LOOP_EXPR, tmp);
6709 gfc_add_expr_to_block (&block, tmp);
6711 /* The exit label. */
6712 tmp = build1_v (LABEL_EXPR, exit_label);
6713 gfc_add_expr_to_block (&block, tmp);
6716 return gfc_finish_block (&block);
6720 /* Generate code to copy a string. */
6723 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6724 int dkind, tree slength, tree src, int skind)
6726 tree tmp, dlen, slen;
6735 stmtblock_t tempblock;
6737 gcc_assert (dkind == skind);
6739 if (slength != NULL_TREE)
6741 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6742 ssc = gfc_string_to_single_character (slen, src, skind);
6746 slen = build_one_cst (gfc_charlen_type_node);
6750 if (dlength != NULL_TREE)
6752 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6753 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6757 dlen = build_one_cst (gfc_charlen_type_node);
6761 /* Assign directly if the types are compatible. */
6762 if (dsc != NULL_TREE && ssc != NULL_TREE
6763 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6765 gfc_add_modify (block, dsc, ssc);
6769 /* The string copy algorithm below generates code like
6773 if (srclen < destlen)
6775 memmove (dest, src, srclen);
6777 memset (&dest[srclen], ' ', destlen - srclen);
6781 // Truncate if too long.
6782 memmove (dest, src, destlen);
6787 /* Do nothing if the destination length is zero. */
6788 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6789 build_zero_cst (TREE_TYPE (dlen)));
6791 /* For non-default character kinds, we have to multiply the string
6792 length by the base type size. */
6793 chartype = gfc_get_char_type (dkind);
6794 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6796 fold_convert (TREE_TYPE (slen),
6797 TYPE_SIZE_UNIT (chartype)));
6798 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6800 fold_convert (TREE_TYPE (dlen),
6801 TYPE_SIZE_UNIT (chartype)));
6803 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6804 dest = fold_convert (pvoid_type_node, dest);
6806 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6808 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6809 src = fold_convert (pvoid_type_node, src);
6811 src = gfc_build_addr_expr (pvoid_type_node, src);
6813 /* Truncate string if source is too long. */
6814 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6817 /* Copy and pad with spaces. */
6818 tmp3 = build_call_expr_loc (input_location,
6819 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6821 fold_convert (size_type_node, slen));
6823 /* Wstringop-overflow appears at -O3 even though this warning is not
6824 explicitly available in fortran nor can it be switched off. If the
6825 source length is a constant, its negative appears as a very large
6826 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6827 the result of the MINUS_EXPR suppresses this spurious warning. */
6828 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6829 TREE_TYPE(dlen), dlen, slen);
6830 if (slength && TREE_CONSTANT (slength))
6831 tmp = gfc_evaluate_now (tmp, block);
6833 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6834 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6836 gfc_init_block (&tempblock);
6837 gfc_add_expr_to_block (&tempblock, tmp3);
6838 gfc_add_expr_to_block (&tempblock, tmp4);
6839 tmp3 = gfc_finish_block (&tempblock);
6841 /* The truncated memmove if the slen >= dlen. */
6842 tmp2 = build_call_expr_loc (input_location,
6843 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6845 fold_convert (size_type_node, dlen));
6847 /* The whole copy_string function is there. */
6848 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6850 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6851 build_empty_stmt (input_location));
6852 gfc_add_expr_to_block (block, tmp);
6856 /* Translate a statement function.
6857 The value of a statement function reference is obtained by evaluating the
6858 expression using the values of the actual arguments for the values of the
6859 corresponding dummy arguments. */
6862 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6866 gfc_formal_arglist *fargs;
6867 gfc_actual_arglist *args;
6870 gfc_saved_var *saved_vars;
6876 sym = expr->symtree->n.sym;
6877 args = expr->value.function.actual;
6878 gfc_init_se (&lse, NULL);
6879 gfc_init_se (&rse, NULL);
6882 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6884 saved_vars = XCNEWVEC (gfc_saved_var, n);
6885 temp_vars = XCNEWVEC (tree, n);
6887 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6888 fargs = fargs->next, n++)
6890 /* Each dummy shall be specified, explicitly or implicitly, to be
6892 gcc_assert (fargs->sym->attr.dimension == 0);
6895 if (fsym->ts.type == BT_CHARACTER)
6897 /* Copy string arguments. */
6900 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6901 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6903 /* Create a temporary to hold the value. */
6904 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6905 fsym->ts.u.cl->backend_decl
6906 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6908 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6909 temp_vars[n] = gfc_create_var (type, fsym->name);
6911 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6913 gfc_conv_expr (&rse, args->expr);
6914 gfc_conv_string_parameter (&rse);
6915 gfc_add_block_to_block (&se->pre, &lse.pre);
6916 gfc_add_block_to_block (&se->pre, &rse.pre);
6918 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6919 rse.string_length, rse.expr, fsym->ts.kind);
6920 gfc_add_block_to_block (&se->pre, &lse.post);
6921 gfc_add_block_to_block (&se->pre, &rse.post);
6925 /* For everything else, just evaluate the expression. */
6927 /* Create a temporary to hold the value. */
6928 type = gfc_typenode_for_spec (&fsym->ts);
6929 temp_vars[n] = gfc_create_var (type, fsym->name);
6931 gfc_conv_expr (&lse, args->expr);
6933 gfc_add_block_to_block (&se->pre, &lse.pre);
6934 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6935 gfc_add_block_to_block (&se->pre, &lse.post);
6941 /* Use the temporary variables in place of the real ones. */
6942 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6943 fargs = fargs->next, n++)
6944 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6946 gfc_conv_expr (se, sym->value);
6948 if (sym->ts.type == BT_CHARACTER)
6950 gfc_conv_const_charlen (sym->ts.u.cl);
6952 /* Force the expression to the correct length. */
6953 if (!INTEGER_CST_P (se->string_length)
6954 || tree_int_cst_lt (se->string_length,
6955 sym->ts.u.cl->backend_decl))
6957 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6958 tmp = gfc_create_var (type, sym->name);
6959 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6960 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6961 sym->ts.kind, se->string_length, se->expr,
6965 se->string_length = sym->ts.u.cl->backend_decl;
6968 /* Restore the original variables. */
6969 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6970 fargs = fargs->next, n++)
6971 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6977 /* Translate a function expression. */
6980 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6984 if (expr->value.function.isym)
6986 gfc_conv_intrinsic_function (se, expr);
6990 /* expr.value.function.esym is the resolved (specific) function symbol for
6991 most functions. However this isn't set for dummy procedures. */
6992 sym = expr->value.function.esym;
6994 sym = expr->symtree->n.sym;
6996 /* The IEEE_ARITHMETIC functions are caught here. */
6997 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6998 if (gfc_conv_ieee_arithmetic_function (se, expr))
7001 /* We distinguish statement functions from general functions to improve
7002 runtime performance. */
7003 if (sym->attr.proc == PROC_ST_FUNCTION)
7005 gfc_conv_statement_function (se, expr);
7009 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7014 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7017 is_zero_initializer_p (gfc_expr * expr)
7019 if (expr->expr_type != EXPR_CONSTANT)
7022 /* We ignore constants with prescribed memory representations for now. */
7023 if (expr->representation.string)
7026 switch (expr->ts.type)
7029 return mpz_cmp_si (expr->value.integer, 0) == 0;
7032 return mpfr_zero_p (expr->value.real)
7033 && MPFR_SIGN (expr->value.real) >= 0;
7036 return expr->value.logical == 0;
7039 return mpfr_zero_p (mpc_realref (expr->value.complex))
7040 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7041 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7042 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7052 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7057 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7058 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7060 gfc_conv_tmp_array_ref (se);
7064 /* Build a static initializer. EXPR is the expression for the initial value.
7065 The other parameters describe the variable of the component being
7066 initialized. EXPR may be null. */
7069 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7070 bool array, bool pointer, bool procptr)
7074 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7075 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7076 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7077 return build_constructor (type, NULL);
7079 if (!(expr || pointer || procptr))
7082 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7083 (these are the only two iso_c_binding derived types that can be
7084 used as initialization expressions). If so, we need to modify
7085 the 'expr' to be that for a (void *). */
7086 if (expr != NULL && expr->ts.type == BT_DERIVED
7087 && expr->ts.is_iso_c && expr->ts.u.derived)
7089 gfc_symbol *derived = expr->ts.u.derived;
7091 /* The derived symbol has already been converted to a (void *). Use
7093 if (derived->ts.kind == 0)
7094 derived->ts.kind = gfc_default_integer_kind;
7095 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
7096 expr->ts.f90_type = derived->ts.f90_type;
7098 gfc_init_se (&se, NULL);
7099 gfc_conv_constant (&se, expr);
7100 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7104 if (array && !procptr)
7107 /* Arrays need special handling. */
7109 ctor = gfc_build_null_descriptor (type);
7110 /* Special case assigning an array to zero. */
7111 else if (is_zero_initializer_p (expr))
7112 ctor = build_constructor (type, NULL);
7114 ctor = gfc_conv_array_initializer (type, expr);
7115 TREE_STATIC (ctor) = 1;
7118 else if (pointer || procptr)
7120 if (ts->type == BT_CLASS && !procptr)
7122 gfc_init_se (&se, NULL);
7123 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7124 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7125 TREE_STATIC (se.expr) = 1;
7128 else if (!expr || expr->expr_type == EXPR_NULL)
7129 return fold_convert (type, null_pointer_node);
7132 gfc_init_se (&se, NULL);
7133 se.want_pointer = 1;
7134 gfc_conv_expr (&se, expr);
7135 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7145 gfc_init_se (&se, NULL);
7146 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7147 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7149 gfc_conv_structure (&se, expr, 1);
7150 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7151 TREE_STATIC (se.expr) = 1;
7156 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7157 TREE_STATIC (ctor) = 1;
7162 gfc_init_se (&se, NULL);
7163 gfc_conv_constant (&se, expr);
7164 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7171 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7177 gfc_array_info *lss_array;
7184 gfc_start_block (&block);
7186 /* Initialize the scalarizer. */
7187 gfc_init_loopinfo (&loop);
7189 gfc_init_se (&lse, NULL);
7190 gfc_init_se (&rse, NULL);
7193 rss = gfc_walk_expr (expr);
7194 if (rss == gfc_ss_terminator)
7195 /* The rhs is scalar. Add a ss for the expression. */
7196 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7198 /* Create a SS for the destination. */
7199 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7201 lss_array = &lss->info->data.array;
7202 lss_array->shape = gfc_get_shape (cm->as->rank);
7203 lss_array->descriptor = dest;
7204 lss_array->data = gfc_conv_array_data (dest);
7205 lss_array->offset = gfc_conv_array_offset (dest);
7206 for (n = 0; n < cm->as->rank; n++)
7208 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7209 lss_array->stride[n] = gfc_index_one_node;
7211 mpz_init (lss_array->shape[n]);
7212 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7213 cm->as->lower[n]->value.integer);
7214 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7217 /* Associate the SS with the loop. */
7218 gfc_add_ss_to_loop (&loop, lss);
7219 gfc_add_ss_to_loop (&loop, rss);
7221 /* Calculate the bounds of the scalarization. */
7222 gfc_conv_ss_startstride (&loop);
7224 /* Setup the scalarizing loops. */
7225 gfc_conv_loop_setup (&loop, &expr->where);
7227 /* Setup the gfc_se structures. */
7228 gfc_copy_loopinfo_to_se (&lse, &loop);
7229 gfc_copy_loopinfo_to_se (&rse, &loop);
7232 gfc_mark_ss_chain_used (rss, 1);
7234 gfc_mark_ss_chain_used (lss, 1);
7236 /* Start the scalarized loop body. */
7237 gfc_start_scalarized_body (&loop, &body);
7239 gfc_conv_tmp_array_ref (&lse);
7240 if (cm->ts.type == BT_CHARACTER)
7241 lse.string_length = cm->ts.u.cl->backend_decl;
7243 gfc_conv_expr (&rse, expr);
7245 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7246 gfc_add_expr_to_block (&body, tmp);
7248 gcc_assert (rse.ss == gfc_ss_terminator);
7250 /* Generate the copying loops. */
7251 gfc_trans_scalarizing_loops (&loop, &body);
7253 /* Wrap the whole thing up. */
7254 gfc_add_block_to_block (&block, &loop.pre);
7255 gfc_add_block_to_block (&block, &loop.post);
7257 gcc_assert (lss_array->shape != NULL);
7258 gfc_free_shape (&lss_array->shape, cm->as->rank);
7259 gfc_cleanup_loop (&loop);
7261 return gfc_finish_block (&block);
7266 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7276 gfc_expr *arg = NULL;
7278 gfc_start_block (&block);
7279 gfc_init_se (&se, NULL);
7281 /* Get the descriptor for the expressions. */
7282 se.want_pointer = 0;
7283 gfc_conv_expr_descriptor (&se, expr);
7284 gfc_add_block_to_block (&block, &se.pre);
7285 gfc_add_modify (&block, dest, se.expr);
7287 /* Deal with arrays of derived types with allocatable components. */
7288 if (gfc_bt_struct (cm->ts.type)
7289 && cm->ts.u.derived->attr.alloc_comp)
7290 // TODO: Fix caf_mode
7291 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7294 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7295 && CLASS_DATA(cm)->attr.allocatable)
7297 if (cm->ts.u.derived->attr.alloc_comp)
7298 // TODO: Fix caf_mode
7299 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7304 tmp = TREE_TYPE (dest);
7305 tmp = gfc_duplicate_allocatable (dest, se.expr,
7306 tmp, expr->rank, NULL_TREE);
7310 tmp = gfc_duplicate_allocatable (dest, se.expr,
7311 TREE_TYPE(cm->backend_decl),
7312 cm->as->rank, NULL_TREE);
7314 gfc_add_expr_to_block (&block, tmp);
7315 gfc_add_block_to_block (&block, &se.post);
7317 if (expr->expr_type != EXPR_VARIABLE)
7318 gfc_conv_descriptor_data_set (&block, se.expr,
7321 /* We need to know if the argument of a conversion function is a
7322 variable, so that the correct lower bound can be used. */
7323 if (expr->expr_type == EXPR_FUNCTION
7324 && expr->value.function.isym
7325 && expr->value.function.isym->conversion
7326 && expr->value.function.actual->expr
7327 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7328 arg = expr->value.function.actual->expr;
7330 /* Obtain the array spec of full array references. */
7332 as = gfc_get_full_arrayspec_from_expr (arg);
7334 as = gfc_get_full_arrayspec_from_expr (expr);
7336 /* Shift the lbound and ubound of temporaries to being unity,
7337 rather than zero, based. Always calculate the offset. */
7338 offset = gfc_conv_descriptor_offset_get (dest);
7339 gfc_add_modify (&block, offset, gfc_index_zero_node);
7340 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7342 for (n = 0; n < expr->rank; n++)
7347 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7348 TODO It looks as if gfc_conv_expr_descriptor should return
7349 the correct bounds and that the following should not be
7350 necessary. This would simplify gfc_conv_intrinsic_bound
7352 if (as && as->lower[n])
7355 gfc_init_se (&lbse, NULL);
7356 gfc_conv_expr (&lbse, as->lower[n]);
7357 gfc_add_block_to_block (&block, &lbse.pre);
7358 lbound = gfc_evaluate_now (lbse.expr, &block);
7362 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7363 lbound = gfc_conv_descriptor_lbound_get (tmp,
7367 lbound = gfc_conv_descriptor_lbound_get (dest,
7370 lbound = gfc_index_one_node;
7372 lbound = fold_convert (gfc_array_index_type, lbound);
7374 /* Shift the bounds and set the offset accordingly. */
7375 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7376 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7377 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7378 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7380 gfc_conv_descriptor_ubound_set (&block, dest,
7381 gfc_rank_cst[n], tmp);
7382 gfc_conv_descriptor_lbound_set (&block, dest,
7383 gfc_rank_cst[n], lbound);
7385 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7386 gfc_conv_descriptor_lbound_get (dest,
7388 gfc_conv_descriptor_stride_get (dest,
7390 gfc_add_modify (&block, tmp2, tmp);
7391 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7393 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7398 /* If a conversion expression has a null data pointer
7399 argument, nullify the allocatable component. */
7403 if (arg->symtree->n.sym->attr.allocatable
7404 || arg->symtree->n.sym->attr.pointer)
7406 non_null_expr = gfc_finish_block (&block);
7407 gfc_start_block (&block);
7408 gfc_conv_descriptor_data_set (&block, dest,
7410 null_expr = gfc_finish_block (&block);
7411 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7412 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7413 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7414 return build3_v (COND_EXPR, tmp,
7415 null_expr, non_null_expr);
7419 return gfc_finish_block (&block);
7423 /* Allocate or reallocate scalar component, as necessary. */
7426 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7436 tree lhs_cl_size = NULL_TREE;
7441 if (!expr2 || expr2->rank)
7444 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7446 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7448 char name[GFC_MAX_SYMBOL_LEN+9];
7449 gfc_component *strlen;
7450 /* Use the rhs string length and the lhs element size. */
7451 gcc_assert (expr2->ts.type == BT_CHARACTER);
7452 if (!expr2->ts.u.cl->backend_decl)
7454 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7455 gcc_assert (expr2->ts.u.cl->backend_decl);
7458 size = expr2->ts.u.cl->backend_decl;
7460 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7462 sprintf (name, "_%s_length", cm->name);
7463 strlen = gfc_find_component (sym, name, true, true, NULL);
7464 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7465 gfc_charlen_type_node,
7466 TREE_OPERAND (comp, 0),
7467 strlen->backend_decl, NULL_TREE);
7469 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7470 tmp = TYPE_SIZE_UNIT (tmp);
7471 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7472 TREE_TYPE (tmp), tmp,
7473 fold_convert (TREE_TYPE (tmp), size));
7475 else if (cm->ts.type == BT_CLASS)
7477 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7478 if (expr2->ts.type == BT_DERIVED)
7480 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7481 size = TYPE_SIZE_UNIT (tmp);
7487 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7488 gfc_add_vptr_component (e2vtab);
7489 gfc_add_size_component (e2vtab);
7490 gfc_init_se (&se, NULL);
7491 gfc_conv_expr (&se, e2vtab);
7492 gfc_add_block_to_block (block, &se.pre);
7493 size = fold_convert (size_type_node, se.expr);
7494 gfc_free_expr (e2vtab);
7496 size_in_bytes = size;
7500 /* Otherwise use the length in bytes of the rhs. */
7501 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7502 size_in_bytes = size;
7505 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7506 size_in_bytes, size_one_node);
7508 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7510 tmp = build_call_expr_loc (input_location,
7511 builtin_decl_explicit (BUILT_IN_CALLOC),
7512 2, build_one_cst (size_type_node),
7514 tmp = fold_convert (TREE_TYPE (comp), tmp);
7515 gfc_add_modify (block, comp, tmp);
7519 tmp = build_call_expr_loc (input_location,
7520 builtin_decl_explicit (BUILT_IN_MALLOC),
7522 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7523 ptr = gfc_class_data_get (comp);
7526 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7527 gfc_add_modify (block, ptr, tmp);
7530 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7531 /* Update the lhs character length. */
7532 gfc_add_modify (block, lhs_cl_size,
7533 fold_convert (TREE_TYPE (lhs_cl_size), size));
7537 /* Assign a single component of a derived type constructor. */
7540 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7541 gfc_symbol *sym, bool init)
7549 gfc_start_block (&block);
7551 if (cm->attr.pointer || cm->attr.proc_pointer)
7553 /* Only care about pointers here, not about allocatables. */
7554 gfc_init_se (&se, NULL);
7555 /* Pointer component. */
7556 if ((cm->attr.dimension || cm->attr.codimension)
7557 && !cm->attr.proc_pointer)
7559 /* Array pointer. */
7560 if (expr->expr_type == EXPR_NULL)
7561 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7564 se.direct_byref = 1;
7566 gfc_conv_expr_descriptor (&se, expr);
7567 gfc_add_block_to_block (&block, &se.pre);
7568 gfc_add_block_to_block (&block, &se.post);
7573 /* Scalar pointers. */
7574 se.want_pointer = 1;
7575 gfc_conv_expr (&se, expr);
7576 gfc_add_block_to_block (&block, &se.pre);
7578 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7579 && expr->symtree->n.sym->attr.dummy)
7580 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7582 gfc_add_modify (&block, dest,
7583 fold_convert (TREE_TYPE (dest), se.expr));
7584 gfc_add_block_to_block (&block, &se.post);
7587 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7589 /* NULL initialization for CLASS components. */
7590 tmp = gfc_trans_structure_assign (dest,
7591 gfc_class_initializer (&cm->ts, expr),
7593 gfc_add_expr_to_block (&block, tmp);
7595 else if ((cm->attr.dimension || cm->attr.codimension)
7596 && !cm->attr.proc_pointer)
7598 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7599 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7600 else if (cm->attr.allocatable || cm->attr.pdt_array)
7602 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7603 gfc_add_expr_to_block (&block, tmp);
7607 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7608 gfc_add_expr_to_block (&block, tmp);
7611 else if (cm->ts.type == BT_CLASS
7612 && CLASS_DATA (cm)->attr.dimension
7613 && CLASS_DATA (cm)->attr.allocatable
7614 && expr->ts.type == BT_DERIVED)
7616 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7617 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7618 tmp = gfc_class_vptr_get (dest);
7619 gfc_add_modify (&block, tmp,
7620 fold_convert (TREE_TYPE (tmp), vtab));
7621 tmp = gfc_class_data_get (dest);
7622 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7623 gfc_add_expr_to_block (&block, tmp);
7625 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7627 /* NULL initialization for allocatable components. */
7628 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7629 null_pointer_node));
7631 else if (init && (cm->attr.allocatable
7632 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7633 && expr->ts.type != BT_CLASS)))
7635 /* Take care about non-array allocatable components here. The alloc_*
7636 routine below is motivated by the alloc_scalar_allocatable_for_
7637 assignment() routine, but with the realloc portions removed and
7639 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7644 /* The remainder of these instructions follow the if (cm->attr.pointer)
7645 if (!cm->attr.dimension) part above. */
7646 gfc_init_se (&se, NULL);
7647 gfc_conv_expr (&se, expr);
7648 gfc_add_block_to_block (&block, &se.pre);
7650 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7651 && expr->symtree->n.sym->attr.dummy)
7652 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7654 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7656 tmp = gfc_class_data_get (dest);
7657 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7658 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7659 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7660 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7661 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7664 tmp = build_fold_indirect_ref_loc (input_location, dest);
7666 /* For deferred strings insert a memcpy. */
7667 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7670 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7671 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7673 : expr->ts.u.cl->backend_decl);
7674 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7675 gfc_add_expr_to_block (&block, tmp);
7678 gfc_add_modify (&block, tmp,
7679 fold_convert (TREE_TYPE (tmp), se.expr));
7680 gfc_add_block_to_block (&block, &se.post);
7682 else if (expr->ts.type == BT_UNION)
7685 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7686 /* We mark that the entire union should be initialized with a contrived
7687 EXPR_NULL expression at the beginning. */
7688 if (c != NULL && c->n.component == NULL
7689 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7691 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7692 dest, build_constructor (TREE_TYPE (dest), NULL));
7693 gfc_add_expr_to_block (&block, tmp);
7694 c = gfc_constructor_next (c);
7696 /* The following constructor expression, if any, represents a specific
7697 map intializer, as given by the user. */
7698 if (c != NULL && c->expr != NULL)
7700 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7701 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7702 gfc_add_expr_to_block (&block, tmp);
7705 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7707 if (expr->expr_type != EXPR_STRUCTURE)
7709 tree dealloc = NULL_TREE;
7710 gfc_init_se (&se, NULL);
7711 gfc_conv_expr (&se, expr);
7712 gfc_add_block_to_block (&block, &se.pre);
7713 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7714 expression in a temporary variable and deallocate the allocatable
7715 components. Then we can the copy the expression to the result. */
7716 if (cm->ts.u.derived->attr.alloc_comp
7717 && expr->expr_type != EXPR_VARIABLE)
7719 se.expr = gfc_evaluate_now (se.expr, &block);
7720 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7723 gfc_add_modify (&block, dest,
7724 fold_convert (TREE_TYPE (dest), se.expr));
7725 if (cm->ts.u.derived->attr.alloc_comp
7726 && expr->expr_type != EXPR_NULL)
7728 // TODO: Fix caf_mode
7729 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7730 dest, expr->rank, 0);
7731 gfc_add_expr_to_block (&block, tmp);
7732 if (dealloc != NULL_TREE)
7733 gfc_add_expr_to_block (&block, dealloc);
7735 gfc_add_block_to_block (&block, &se.post);
7739 /* Nested constructors. */
7740 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7741 gfc_add_expr_to_block (&block, tmp);
7744 else if (gfc_deferred_strlen (cm, &tmp))
7748 gcc_assert (strlen);
7749 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7751 TREE_OPERAND (dest, 0),
7754 if (expr->expr_type == EXPR_NULL)
7756 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7757 gfc_add_modify (&block, dest, tmp);
7758 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7759 gfc_add_modify (&block, strlen, tmp);
7764 gfc_init_se (&se, NULL);
7765 gfc_conv_expr (&se, expr);
7766 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7767 tmp = build_call_expr_loc (input_location,
7768 builtin_decl_explicit (BUILT_IN_MALLOC),
7770 gfc_add_modify (&block, dest,
7771 fold_convert (TREE_TYPE (dest), tmp));
7772 gfc_add_modify (&block, strlen,
7773 fold_convert (TREE_TYPE (strlen), se.string_length));
7774 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7775 gfc_add_expr_to_block (&block, tmp);
7778 else if (!cm->attr.artificial)
7780 /* Scalar component (excluding deferred parameters). */
7781 gfc_init_se (&se, NULL);
7782 gfc_init_se (&lse, NULL);
7784 gfc_conv_expr (&se, expr);
7785 if (cm->ts.type == BT_CHARACTER)
7786 lse.string_length = cm->ts.u.cl->backend_decl;
7788 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7789 gfc_add_expr_to_block (&block, tmp);
7791 return gfc_finish_block (&block);
7794 /* Assign a derived type constructor to a variable. */
7797 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7806 gfc_start_block (&block);
7807 cm = expr->ts.u.derived->components;
7809 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7810 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7811 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7815 gfc_init_se (&se, NULL);
7816 gfc_init_se (&lse, NULL);
7817 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7819 gfc_add_modify (&block, lse.expr,
7820 fold_convert (TREE_TYPE (lse.expr), se.expr));
7822 return gfc_finish_block (&block);
7826 gfc_init_se (&se, NULL);
7828 for (c = gfc_constructor_first (expr->value.constructor);
7829 c; c = gfc_constructor_next (c), cm = cm->next)
7831 /* Skip absent members in default initializers. */
7832 if (!c->expr && !cm->attr.allocatable)
7835 /* Register the component with the caf-lib before it is initialized.
7836 Register only allocatable components, that are not coarray'ed
7837 components (%comp[*]). Only register when the constructor is not the
7839 if (coarray && !cm->attr.codimension
7840 && (cm->attr.allocatable || cm->attr.pointer)
7841 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7843 tree token, desc, size;
7844 bool is_array = cm->ts.type == BT_CLASS
7845 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7847 field = cm->backend_decl;
7848 field = fold_build3_loc (input_location, COMPONENT_REF,
7849 TREE_TYPE (field), dest, field, NULL_TREE);
7850 if (cm->ts.type == BT_CLASS)
7851 field = gfc_class_data_get (field);
7853 token = is_array ? gfc_conv_descriptor_token (field)
7854 : fold_build3_loc (input_location, COMPONENT_REF,
7855 TREE_TYPE (cm->caf_token), dest,
7856 cm->caf_token, NULL_TREE);
7860 /* The _caf_register routine looks at the rank of the array
7861 descriptor to decide whether the data registered is an array
7863 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7865 /* When the rank is not known just set a positive rank, which
7866 suffices to recognize the data as array. */
7869 size = build_zero_cst (size_type_node);
7871 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7872 build_int_cst (signed_char_type_node, rank));
7876 desc = gfc_conv_scalar_to_descriptor (&se, field,
7877 cm->ts.type == BT_CLASS
7878 ? CLASS_DATA (cm)->attr
7880 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7882 gfc_add_block_to_block (&block, &se.pre);
7883 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7884 7, size, build_int_cst (
7886 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7887 gfc_build_addr_expr (pvoid_type_node,
7889 gfc_build_addr_expr (NULL_TREE, desc),
7890 null_pointer_node, null_pointer_node,
7892 gfc_add_expr_to_block (&block, tmp);
7894 field = cm->backend_decl;
7895 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7896 dest, field, NULL_TREE);
7899 gfc_expr *e = gfc_get_null_expr (NULL);
7900 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7905 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7906 expr->ts.u.derived, init);
7907 gfc_add_expr_to_block (&block, tmp);
7909 return gfc_finish_block (&block);
7913 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7914 gfc_component *un, gfc_expr *init)
7916 gfc_constructor *ctor;
7918 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7921 ctor = gfc_constructor_first (init->value.constructor);
7923 if (ctor == NULL || ctor->expr == NULL)
7926 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7928 /* If we have an 'initialize all' constructor, do it first. */
7929 if (ctor->expr->expr_type == EXPR_NULL)
7931 tree union_type = TREE_TYPE (un->backend_decl);
7932 tree val = build_constructor (union_type, NULL);
7933 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7934 ctor = gfc_constructor_next (ctor);
7937 /* Add the map initializer on top. */
7938 if (ctor != NULL && ctor->expr != NULL)
7940 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7941 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7942 TREE_TYPE (un->backend_decl),
7943 un->attr.dimension, un->attr.pointer,
7944 un->attr.proc_pointer);
7945 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7949 /* Build an expression for a constructor. If init is nonzero then
7950 this is part of a static variable initializer. */
7953 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7960 vec<constructor_elt, va_gc> *v = NULL;
7962 gcc_assert (se->ss == NULL);
7963 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7964 type = gfc_typenode_for_spec (&expr->ts);
7968 /* Create a temporary variable and fill it in. */
7969 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7970 /* The symtree in expr is NULL, if the code to generate is for
7971 initializing the static members only. */
7972 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7974 gfc_add_expr_to_block (&se->pre, tmp);
7978 cm = expr->ts.u.derived->components;
7980 for (c = gfc_constructor_first (expr->value.constructor);
7981 c; c = gfc_constructor_next (c), cm = cm->next)
7983 /* Skip absent members in default initializers and allocatable
7984 components. Although the latter have a default initializer
7985 of EXPR_NULL,... by default, the static nullify is not needed
7986 since this is done every time we come into scope. */
7987 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7990 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7991 && strcmp (cm->name, "_extends") == 0
7992 && cm->initializer->symtree)
7996 vtabs = cm->initializer->symtree->n.sym;
7997 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7998 vtab = unshare_expr_without_location (vtab);
7999 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8001 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8003 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8004 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8005 fold_convert (TREE_TYPE (cm->backend_decl),
8008 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8009 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8010 fold_convert (TREE_TYPE (cm->backend_decl),
8011 integer_zero_node));
8012 else if (cm->ts.type == BT_UNION)
8013 gfc_conv_union_initializer (v, cm, c->expr);
8016 val = gfc_conv_initializer (c->expr, &cm->ts,
8017 TREE_TYPE (cm->backend_decl),
8018 cm->attr.dimension, cm->attr.pointer,
8019 cm->attr.proc_pointer);
8020 val = unshare_expr_without_location (val);
8022 /* Append it to the constructor list. */
8023 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8027 se->expr = build_constructor (type, v);
8029 TREE_CONSTANT (se->expr) = 1;
8033 /* Translate a substring expression. */
8036 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8042 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8044 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8045 expr->value.character.length,
8046 expr->value.character.string);
8048 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8049 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8052 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8056 /* Entry point for expression translation. Evaluates a scalar quantity.
8057 EXPR is the expression to be translated, and SE is the state structure if
8058 called from within the scalarized. */
8061 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8066 if (ss && ss->info->expr == expr
8067 && (ss->info->type == GFC_SS_SCALAR
8068 || ss->info->type == GFC_SS_REFERENCE))
8070 gfc_ss_info *ss_info;
8073 /* Substitute a scalar expression evaluated outside the scalarization
8075 se->expr = ss_info->data.scalar.value;
8076 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8077 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8079 se->string_length = ss_info->string_length;
8080 gfc_advance_se_ss_chain (se);
8084 /* We need to convert the expressions for the iso_c_binding derived types.
8085 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8086 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8087 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8088 updated to be an integer with a kind equal to the size of a (void *). */
8089 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8090 && expr->ts.u.derived->attr.is_bind_c)
8092 if (expr->expr_type == EXPR_VARIABLE
8093 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8094 || expr->symtree->n.sym->intmod_sym_id
8095 == ISOCBINDING_NULL_FUNPTR))
8097 /* Set expr_type to EXPR_NULL, which will result in
8098 null_pointer_node being used below. */
8099 expr->expr_type = EXPR_NULL;
8103 /* Update the type/kind of the expression to be what the new
8104 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8105 expr->ts.type = BT_INTEGER;
8106 expr->ts.f90_type = BT_VOID;
8107 expr->ts.kind = gfc_index_integer_kind;
8111 gfc_fix_class_refs (expr);
8113 switch (expr->expr_type)
8116 gfc_conv_expr_op (se, expr);
8120 gfc_conv_function_expr (se, expr);
8124 gfc_conv_constant (se, expr);
8128 gfc_conv_variable (se, expr);
8132 se->expr = null_pointer_node;
8135 case EXPR_SUBSTRING:
8136 gfc_conv_substring_expr (se, expr);
8139 case EXPR_STRUCTURE:
8140 gfc_conv_structure (se, expr, 0);
8144 gfc_conv_array_constructor_expr (se, expr);
8153 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8154 of an assignment. */
8156 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8158 gfc_conv_expr (se, expr);
8159 /* All numeric lvalues should have empty post chains. If not we need to
8160 figure out a way of rewriting an lvalue so that it has no post chain. */
8161 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8164 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8165 numeric expressions. Used for scalar values where inserting cleanup code
8168 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8172 gcc_assert (expr->ts.type != BT_CHARACTER);
8173 gfc_conv_expr (se, expr);
8176 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8177 gfc_add_modify (&se->pre, val, se->expr);
8179 gfc_add_block_to_block (&se->pre, &se->post);
8183 /* Helper to translate an expression and convert it to a particular type. */
8185 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8187 gfc_conv_expr_val (se, expr);
8188 se->expr = convert (type, se->expr);
8192 /* Converts an expression so that it can be passed by reference. Scalar
8196 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8202 if (ss && ss->info->expr == expr
8203 && ss->info->type == GFC_SS_REFERENCE)
8205 /* Returns a reference to the scalar evaluated outside the loop
8207 gfc_conv_expr (se, expr);
8209 if (expr->ts.type == BT_CHARACTER
8210 && expr->expr_type != EXPR_FUNCTION)
8211 gfc_conv_string_parameter (se);
8213 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8218 if (expr->ts.type == BT_CHARACTER)
8220 gfc_conv_expr (se, expr);
8221 gfc_conv_string_parameter (se);
8225 if (expr->expr_type == EXPR_VARIABLE)
8227 se->want_pointer = 1;
8228 gfc_conv_expr (se, expr);
8231 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8232 gfc_add_modify (&se->pre, var, se->expr);
8233 gfc_add_block_to_block (&se->pre, &se->post);
8236 else if (add_clobber && expr->ref == NULL)
8240 /* FIXME: This fails if var is passed by reference, see PR
8242 var = expr->symtree->n.sym->backend_decl;
8243 clobber = build_clobber (TREE_TYPE (var));
8244 gfc_add_modify (&se->pre, var, clobber);
8249 if (expr->expr_type == EXPR_FUNCTION
8250 && ((expr->value.function.esym
8251 && expr->value.function.esym->result->attr.pointer
8252 && !expr->value.function.esym->result->attr.dimension)
8253 || (!expr->value.function.esym && !expr->ref
8254 && expr->symtree->n.sym->attr.pointer
8255 && !expr->symtree->n.sym->attr.dimension)))
8257 se->want_pointer = 1;
8258 gfc_conv_expr (se, expr);
8259 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8260 gfc_add_modify (&se->pre, var, se->expr);
8265 gfc_conv_expr (se, expr);
8267 /* Create a temporary var to hold the value. */
8268 if (TREE_CONSTANT (se->expr))
8270 tree tmp = se->expr;
8271 STRIP_TYPE_NOPS (tmp);
8272 var = build_decl (input_location,
8273 CONST_DECL, NULL, TREE_TYPE (tmp));
8274 DECL_INITIAL (var) = tmp;
8275 TREE_STATIC (var) = 1;
8280 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8281 gfc_add_modify (&se->pre, var, se->expr);
8284 if (!expr->must_finalize)
8285 gfc_add_block_to_block (&se->pre, &se->post);
8287 /* Take the address of that value. */
8288 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8292 /* Get the _len component for an unlimited polymorphic expression. */
8295 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8298 gfc_ref *ref = expr->ref;
8300 gfc_init_se (&se, NULL);
8301 while (ref && ref->next)
8303 gfc_add_len_component (expr);
8304 gfc_conv_expr (&se, expr);
8305 gfc_add_block_to_block (block, &se.pre);
8306 gcc_assert (se.post.head == NULL_TREE);
8309 gfc_free_ref_list (ref->next);
8314 gfc_free_ref_list (expr->ref);
8321 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8322 statement-list outside of the scalarizer-loop. When code is generated, that
8323 depends on the scalarized expression, it is added to RSE.PRE.
8324 Returns le's _vptr tree and when set the len expressions in to_lenp and
8325 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8329 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8330 gfc_expr * re, gfc_se *rse,
8331 tree * to_lenp, tree * from_lenp)
8334 gfc_expr * vptr_expr;
8335 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8336 bool set_vptr = false, temp_rhs = false;
8337 stmtblock_t *pre = block;
8339 /* Create a temporary for complicated expressions. */
8340 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8341 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8343 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8345 gfc_add_modify (&rse->pre, tmp, rse->expr);
8350 /* Get the _vptr for the left-hand side expression. */
8351 gfc_init_se (&se, NULL);
8352 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8353 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8355 /* Care about _len for unlimited polymorphic entities. */
8356 if (UNLIMITED_POLY (vptr_expr)
8357 || (vptr_expr->ts.type == BT_DERIVED
8358 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8359 to_len = trans_get_upoly_len (block, vptr_expr);
8360 gfc_add_vptr_component (vptr_expr);
8364 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8365 se.want_pointer = 1;
8366 gfc_conv_expr (&se, vptr_expr);
8367 gfc_free_expr (vptr_expr);
8368 gfc_add_block_to_block (block, &se.pre);
8369 gcc_assert (se.post.head == NULL_TREE);
8371 STRIP_NOPS (lhs_vptr);
8373 /* Set the _vptr only when the left-hand side of the assignment is a
8377 /* Get the vptr from the rhs expression only, when it is variable.
8378 Functions are expected to be assigned to a temporary beforehand. */
8379 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8380 ? gfc_find_and_cut_at_last_class_ref (re)
8382 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8384 if (to_len != NULL_TREE)
8386 /* Get the _len information from the rhs. */
8387 if (UNLIMITED_POLY (vptr_expr)
8388 || (vptr_expr->ts.type == BT_DERIVED
8389 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8390 from_len = trans_get_upoly_len (block, vptr_expr);
8392 gfc_add_vptr_component (vptr_expr);
8396 if (re->expr_type == EXPR_VARIABLE
8397 && DECL_P (re->symtree->n.sym->backend_decl)
8398 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8399 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8400 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8401 re->symtree->n.sym->backend_decl))))
8404 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8405 re->symtree->n.sym->backend_decl));
8407 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8408 re->symtree->n.sym->backend_decl));
8410 else if (temp_rhs && re->ts.type == BT_CLASS)
8413 se.expr = gfc_class_vptr_get (rse->expr);
8414 if (UNLIMITED_POLY (re))
8415 from_len = gfc_class_len_get (rse->expr);
8417 else if (re->expr_type != EXPR_NULL)
8418 /* Only when rhs is non-NULL use its declared type for vptr
8420 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8422 /* When the rhs is NULL use the vtab of lhs' declared type. */
8423 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8428 gfc_init_se (&se, NULL);
8429 se.want_pointer = 1;
8430 gfc_conv_expr (&se, vptr_expr);
8431 gfc_free_expr (vptr_expr);
8432 gfc_add_block_to_block (block, &se.pre);
8433 gcc_assert (se.post.head == NULL_TREE);
8435 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8438 if (to_len != NULL_TREE)
8440 /* The _len component needs to be set. Figure how to get the
8441 value of the right-hand side. */
8442 if (from_len == NULL_TREE)
8444 if (rse->string_length != NULL_TREE)
8445 from_len = rse->string_length;
8446 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8448 from_len = gfc_get_expr_charlen (re);
8449 gfc_init_se (&se, NULL);
8450 gfc_conv_expr (&se, re->ts.u.cl->length);
8451 gfc_add_block_to_block (block, &se.pre);
8452 gcc_assert (se.post.head == NULL_TREE);
8453 from_len = gfc_evaluate_now (se.expr, block);
8456 from_len = build_zero_cst (gfc_charlen_type_node);
8458 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8463 /* Return the _len trees only, when requested. */
8467 *from_lenp = from_len;
8472 /* Assign tokens for pointer components. */
8475 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8478 symbol_attribute lhs_attr, rhs_attr;
8479 tree tmp, lhs_tok, rhs_tok;
8480 /* Flag to indicated component refs on the rhs. */
8483 lhs_attr = gfc_caf_attr (expr1);
8484 if (expr2->expr_type != EXPR_NULL)
8486 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8487 if (lhs_attr.codimension && rhs_attr.codimension)
8489 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8490 lhs_tok = build_fold_indirect_ref (lhs_tok);
8493 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8497 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8498 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8501 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8503 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8504 gfc_prepend_expr_to_block (&lse->post, tmp);
8507 else if (lhs_attr.codimension)
8509 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8510 lhs_tok = build_fold_indirect_ref (lhs_tok);
8511 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8512 lhs_tok, null_pointer_node);
8513 gfc_prepend_expr_to_block (&lse->post, tmp);
8517 /* Indentify class valued proc_pointer assignments. */
8520 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8525 while (ref && ref->next)
8528 return ref && ref->type == REF_COMPONENT
8529 && ref->u.c.component->attr.proc_pointer
8530 && expr2->expr_type == EXPR_VARIABLE
8531 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8535 /* Do everything that is needed for a CLASS function expr2. */
8538 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8539 gfc_expr *expr1, gfc_expr *expr2)
8541 tree expr1_vptr = NULL_TREE;
8544 gfc_conv_function_expr (rse, expr2);
8545 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8547 if (expr1->ts.type != BT_CLASS)
8548 rse->expr = gfc_class_data_get (rse->expr);
8551 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8554 gfc_add_block_to_block (block, &rse->pre);
8555 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8556 gfc_add_modify (&lse->pre, tmp, rse->expr);
8558 gfc_add_modify (&lse->pre, expr1_vptr,
8559 fold_convert (TREE_TYPE (expr1_vptr),
8560 gfc_class_vptr_get (tmp)));
8561 rse->expr = gfc_class_data_get (tmp);
8569 gfc_trans_pointer_assign (gfc_code * code)
8571 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8575 /* Generate code for a pointer assignment. */
8578 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8585 tree expr1_vptr = NULL_TREE;
8586 bool scalar, non_proc_pointer_assign;
8589 gfc_start_block (&block);
8591 gfc_init_se (&lse, NULL);
8593 /* Usually testing whether this is not a proc pointer assignment. */
8594 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8596 /* Check whether the expression is a scalar or not; we cannot use
8597 expr1->rank as it can be nonzero for proc pointers. */
8598 ss = gfc_walk_expr (expr1);
8599 scalar = ss == gfc_ss_terminator;
8601 gfc_free_ss_chain (ss);
8603 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8604 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8606 gfc_add_data_component (expr2);
8607 /* The following is required as gfc_add_data_component doesn't
8608 update ts.type if there is a tailing REF_ARRAY. */
8609 expr2->ts.type = BT_DERIVED;
8614 /* Scalar pointers. */
8615 lse.want_pointer = 1;
8616 gfc_conv_expr (&lse, expr1);
8617 gfc_init_se (&rse, NULL);
8618 rse.want_pointer = 1;
8619 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8620 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8622 gfc_conv_expr (&rse, expr2);
8624 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8626 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8628 lse.expr = gfc_class_data_get (lse.expr);
8631 if (expr1->symtree->n.sym->attr.proc_pointer
8632 && expr1->symtree->n.sym->attr.dummy)
8633 lse.expr = build_fold_indirect_ref_loc (input_location,
8636 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8637 && expr2->symtree->n.sym->attr.dummy)
8638 rse.expr = build_fold_indirect_ref_loc (input_location,
8641 gfc_add_block_to_block (&block, &lse.pre);
8642 gfc_add_block_to_block (&block, &rse.pre);
8644 /* Check character lengths if character expression. The test is only
8645 really added if -fbounds-check is enabled. Exclude deferred
8646 character length lefthand sides. */
8647 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8648 && !expr1->ts.deferred
8649 && !expr1->symtree->n.sym->attr.proc_pointer
8650 && !gfc_is_proc_ptr_comp (expr1))
8652 gcc_assert (expr2->ts.type == BT_CHARACTER);
8653 gcc_assert (lse.string_length && rse.string_length);
8654 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8655 lse.string_length, rse.string_length,
8659 /* The assignment to an deferred character length sets the string
8660 length to that of the rhs. */
8661 if (expr1->ts.deferred)
8663 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8664 gfc_add_modify (&block, lse.string_length,
8665 fold_convert (TREE_TYPE (lse.string_length),
8666 rse.string_length));
8667 else if (lse.string_length != NULL)
8668 gfc_add_modify (&block, lse.string_length,
8669 build_zero_cst (TREE_TYPE (lse.string_length)));
8672 gfc_add_modify (&block, lse.expr,
8673 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8675 /* Also set the tokens for pointer components in derived typed
8677 if (flag_coarray == GFC_FCOARRAY_LIB)
8678 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8680 gfc_add_block_to_block (&block, &rse.post);
8681 gfc_add_block_to_block (&block, &lse.post);
8688 tree strlen_rhs = NULL_TREE;
8690 /* Array pointer. Find the last reference on the LHS and if it is an
8691 array section ref, we're dealing with bounds remapping. In this case,
8692 set it to AR_FULL so that gfc_conv_expr_descriptor does
8693 not see it and process the bounds remapping afterwards explicitly. */
8694 for (remap = expr1->ref; remap; remap = remap->next)
8695 if (!remap->next && remap->type == REF_ARRAY
8696 && remap->u.ar.type == AR_SECTION)
8698 rank_remap = (remap && remap->u.ar.end[0]);
8700 gfc_init_se (&lse, NULL);
8702 lse.descriptor_only = 1;
8703 gfc_conv_expr_descriptor (&lse, expr1);
8704 strlen_lhs = lse.string_length;
8707 if (expr2->expr_type == EXPR_NULL)
8709 /* Just set the data pointer to null. */
8710 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8712 else if (rank_remap)
8714 /* If we are rank-remapping, just get the RHS's descriptor and
8715 process this later on. */
8716 gfc_init_se (&rse, NULL);
8717 rse.direct_byref = 1;
8718 rse.byref_noassign = 1;
8720 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8721 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8723 else if (expr2->expr_type == EXPR_FUNCTION)
8725 tree bound[GFC_MAX_DIMENSIONS];
8728 for (i = 0; i < expr2->rank; i++)
8729 bound[i] = NULL_TREE;
8730 tmp = gfc_typenode_for_spec (&expr2->ts);
8731 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8733 GFC_ARRAY_POINTER_CONT, false);
8734 tmp = gfc_create_var (tmp, "ptrtemp");
8735 rse.descriptor_only = 0;
8737 rse.direct_byref = 1;
8738 gfc_conv_expr_descriptor (&rse, expr2);
8739 strlen_rhs = rse.string_length;
8744 gfc_conv_expr_descriptor (&rse, expr2);
8745 strlen_rhs = rse.string_length;
8746 if (expr1->ts.type == BT_CLASS)
8747 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8752 else if (expr2->expr_type == EXPR_VARIABLE)
8754 /* Assign directly to the LHS's descriptor. */
8755 lse.descriptor_only = 0;
8756 lse.direct_byref = 1;
8757 gfc_conv_expr_descriptor (&lse, expr2);
8758 strlen_rhs = lse.string_length;
8760 if (expr1->ts.type == BT_CLASS)
8762 rse.expr = NULL_TREE;
8763 rse.string_length = NULL_TREE;
8764 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8770 /* If the target is not a whole array, use the target array
8771 reference for remap. */
8772 for (remap = expr2->ref; remap; remap = remap->next)
8773 if (remap->type == REF_ARRAY
8774 && remap->u.ar.type == AR_FULL
8779 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8781 gfc_init_se (&rse, NULL);
8782 rse.want_pointer = 1;
8783 gfc_conv_function_expr (&rse, expr2);
8784 if (expr1->ts.type != BT_CLASS)
8786 rse.expr = gfc_class_data_get (rse.expr);
8787 gfc_add_modify (&lse.pre, desc, rse.expr);
8788 /* Set the lhs span. */
8789 tmp = TREE_TYPE (rse.expr);
8790 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8791 tmp = fold_convert (gfc_array_index_type, tmp);
8792 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8796 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8799 gfc_add_block_to_block (&block, &rse.pre);
8800 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8801 gfc_add_modify (&lse.pre, tmp, rse.expr);
8803 gfc_add_modify (&lse.pre, expr1_vptr,
8804 fold_convert (TREE_TYPE (expr1_vptr),
8805 gfc_class_vptr_get (tmp)));
8806 rse.expr = gfc_class_data_get (tmp);
8807 gfc_add_modify (&lse.pre, desc, rse.expr);
8812 /* Assign to a temporary descriptor and then copy that
8813 temporary to the pointer. */
8814 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8815 lse.descriptor_only = 0;
8817 lse.direct_byref = 1;
8818 gfc_conv_expr_descriptor (&lse, expr2);
8819 strlen_rhs = lse.string_length;
8820 gfc_add_modify (&lse.pre, desc, tmp);
8823 gfc_add_block_to_block (&block, &lse.pre);
8825 gfc_add_block_to_block (&block, &rse.pre);
8827 /* If we do bounds remapping, update LHS descriptor accordingly. */
8831 gcc_assert (remap->u.ar.dimen == expr1->rank);
8835 /* Do rank remapping. We already have the RHS's descriptor
8836 converted in rse and now have to build the correct LHS
8837 descriptor for it. */
8839 tree dtype, data, span;
8841 tree lbound, ubound;
8844 dtype = gfc_conv_descriptor_dtype (desc);
8845 tmp = gfc_get_dtype (TREE_TYPE (desc));
8846 gfc_add_modify (&block, dtype, tmp);
8848 /* Copy data pointer. */
8849 data = gfc_conv_descriptor_data_get (rse.expr);
8850 gfc_conv_descriptor_data_set (&block, desc, data);
8852 /* Copy the span. */
8853 if (TREE_CODE (rse.expr) == VAR_DECL
8854 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8855 span = gfc_conv_descriptor_span_get (rse.expr);
8858 tmp = TREE_TYPE (rse.expr);
8859 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8860 span = fold_convert (gfc_array_index_type, tmp);
8862 gfc_conv_descriptor_span_set (&block, desc, span);
8864 /* Copy offset but adjust it such that it would correspond
8865 to a lbound of zero. */
8866 offs = gfc_conv_descriptor_offset_get (rse.expr);
8867 for (dim = 0; dim < expr2->rank; ++dim)
8869 stride = gfc_conv_descriptor_stride_get (rse.expr,
8871 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8873 tmp = fold_build2_loc (input_location, MULT_EXPR,
8874 gfc_array_index_type, stride, lbound);
8875 offs = fold_build2_loc (input_location, PLUS_EXPR,
8876 gfc_array_index_type, offs, tmp);
8878 gfc_conv_descriptor_offset_set (&block, desc, offs);
8880 /* Set the bounds as declared for the LHS and calculate strides as
8881 well as another offset update accordingly. */
8882 stride = gfc_conv_descriptor_stride_get (rse.expr,
8884 for (dim = 0; dim < expr1->rank; ++dim)
8889 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8891 /* Convert declared bounds. */
8892 gfc_init_se (&lower_se, NULL);
8893 gfc_init_se (&upper_se, NULL);
8894 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8895 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8897 gfc_add_block_to_block (&block, &lower_se.pre);
8898 gfc_add_block_to_block (&block, &upper_se.pre);
8900 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8901 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8903 lbound = gfc_evaluate_now (lbound, &block);
8904 ubound = gfc_evaluate_now (ubound, &block);
8906 gfc_add_block_to_block (&block, &lower_se.post);
8907 gfc_add_block_to_block (&block, &upper_se.post);
8909 /* Set bounds in descriptor. */
8910 gfc_conv_descriptor_lbound_set (&block, desc,
8911 gfc_rank_cst[dim], lbound);
8912 gfc_conv_descriptor_ubound_set (&block, desc,
8913 gfc_rank_cst[dim], ubound);
8916 stride = gfc_evaluate_now (stride, &block);
8917 gfc_conv_descriptor_stride_set (&block, desc,
8918 gfc_rank_cst[dim], stride);
8920 /* Update offset. */
8921 offs = gfc_conv_descriptor_offset_get (desc);
8922 tmp = fold_build2_loc (input_location, MULT_EXPR,
8923 gfc_array_index_type, lbound, stride);
8924 offs = fold_build2_loc (input_location, MINUS_EXPR,
8925 gfc_array_index_type, offs, tmp);
8926 offs = gfc_evaluate_now (offs, &block);
8927 gfc_conv_descriptor_offset_set (&block, desc, offs);
8929 /* Update stride. */
8930 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8931 stride = fold_build2_loc (input_location, MULT_EXPR,
8932 gfc_array_index_type, stride, tmp);
8937 /* Bounds remapping. Just shift the lower bounds. */
8939 gcc_assert (expr1->rank == expr2->rank);
8941 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8945 gcc_assert (!remap->u.ar.end[dim]);
8946 gfc_init_se (&lbound_se, NULL);
8947 if (remap->u.ar.start[dim])
8949 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8950 gfc_add_block_to_block (&block, &lbound_se.pre);
8953 /* This remap arises from a target that is not a whole
8954 array. The start expressions will be NULL but we need
8955 the lbounds to be one. */
8956 lbound_se.expr = gfc_index_one_node;
8957 gfc_conv_shift_descriptor_lbound (&block, desc,
8958 dim, lbound_se.expr);
8959 gfc_add_block_to_block (&block, &lbound_se.post);
8964 /* Check string lengths if applicable. The check is only really added
8965 to the output code if -fbounds-check is enabled. */
8966 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8968 gcc_assert (expr2->ts.type == BT_CHARACTER);
8969 gcc_assert (strlen_lhs && strlen_rhs);
8970 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8971 strlen_lhs, strlen_rhs, &block);
8974 /* If rank remapping was done, check with -fcheck=bounds that
8975 the target is at least as large as the pointer. */
8976 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8982 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8983 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8985 lsize = gfc_evaluate_now (lsize, &block);
8986 rsize = gfc_evaluate_now (rsize, &block);
8987 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8990 msg = _("Target of rank remapping is too small (%ld < %ld)");
8991 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8995 if (expr1->ts.type == BT_CHARACTER
8996 && expr1->symtree->n.sym->ts.deferred
8997 && expr1->symtree->n.sym->ts.u.cl->backend_decl
8998 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9000 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9001 if (expr2->expr_type != EXPR_NULL)
9002 gfc_add_modify (&block, tmp,
9003 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9005 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9008 gfc_add_block_to_block (&block, &lse.post);
9010 gfc_add_block_to_block (&block, &rse.post);
9013 return gfc_finish_block (&block);
9017 /* Makes sure se is suitable for passing as a function string parameter. */
9018 /* TODO: Need to check all callers of this function. It may be abused. */
9021 gfc_conv_string_parameter (gfc_se * se)
9025 if (TREE_CODE (se->expr) == STRING_CST)
9027 type = TREE_TYPE (TREE_TYPE (se->expr));
9028 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9032 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9034 if (TREE_CODE (se->expr) != INDIRECT_REF)
9036 type = TREE_TYPE (se->expr);
9037 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9041 type = gfc_get_character_type_len (gfc_default_character_kind,
9043 type = build_pointer_type (type);
9044 se->expr = gfc_build_addr_expr (type, se->expr);
9048 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9052 /* Generate code for assignment of scalar variables. Includes character
9053 strings and derived types with allocatable components.
9054 If you know that the LHS has no allocations, set dealloc to false.
9056 DEEP_COPY has no effect if the typespec TS is not a derived type with
9057 allocatable components. Otherwise, if it is set, an explicit copy of each
9058 allocatable component is made. This is necessary as a simple copy of the
9059 whole object would copy array descriptors as is, so that the lhs's
9060 allocatable components would point to the rhs's after the assignment.
9061 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9062 necessary if the rhs is a non-pointer function, as the allocatable components
9063 are not accessible by other means than the function's result after the
9064 function has returned. It is even more subtle when temporaries are involved,
9065 as the two following examples show:
9066 1. When we evaluate an array constructor, a temporary is created. Thus
9067 there is theoretically no alias possible. However, no deep copy is
9068 made for this temporary, so that if the constructor is made of one or
9069 more variable with allocatable components, those components still point
9070 to the variable's: DEEP_COPY should be set for the assignment from the
9071 temporary to the lhs in that case.
9072 2. When assigning a scalar to an array, we evaluate the scalar value out
9073 of the loop, store it into a temporary variable, and assign from that.
9074 In that case, deep copying when assigning to the temporary would be a
9075 waste of resources; however deep copies should happen when assigning from
9076 the temporary to each array element: again DEEP_COPY should be set for
9077 the assignment from the temporary to the lhs. */
9080 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9081 bool deep_copy, bool dealloc, bool in_coarray)
9087 gfc_init_block (&block);
9089 if (ts.type == BT_CHARACTER)
9094 if (lse->string_length != NULL_TREE)
9096 gfc_conv_string_parameter (lse);
9097 gfc_add_block_to_block (&block, &lse->pre);
9098 llen = lse->string_length;
9101 if (rse->string_length != NULL_TREE)
9103 gfc_conv_string_parameter (rse);
9104 gfc_add_block_to_block (&block, &rse->pre);
9105 rlen = rse->string_length;
9108 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9109 rse->expr, ts.kind);
9111 else if (gfc_bt_struct (ts.type)
9112 && (ts.u.derived->attr.alloc_comp
9113 || (deep_copy && ts.u.derived->attr.pdt_type)))
9115 tree tmp_var = NULL_TREE;
9118 /* Are the rhs and the lhs the same? */
9121 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9122 gfc_build_addr_expr (NULL_TREE, lse->expr),
9123 gfc_build_addr_expr (NULL_TREE, rse->expr));
9124 cond = gfc_evaluate_now (cond, &lse->pre);
9127 /* Deallocate the lhs allocated components as long as it is not
9128 the same as the rhs. This must be done following the assignment
9129 to prevent deallocating data that could be used in the rhs
9133 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9134 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9136 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9138 gfc_add_expr_to_block (&lse->post, tmp);
9141 gfc_add_block_to_block (&block, &rse->pre);
9142 gfc_add_block_to_block (&block, &lse->pre);
9144 gfc_add_modify (&block, lse->expr,
9145 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9147 /* Restore pointer address of coarray components. */
9148 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9150 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9151 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9153 gfc_add_expr_to_block (&block, tmp);
9156 /* Do a deep copy if the rhs is a variable, if it is not the
9160 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9161 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9162 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9164 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9166 gfc_add_expr_to_block (&block, tmp);
9169 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9171 gfc_add_block_to_block (&block, &lse->pre);
9172 gfc_add_block_to_block (&block, &rse->pre);
9173 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9174 TREE_TYPE (lse->expr), rse->expr);
9175 gfc_add_modify (&block, lse->expr, tmp);
9179 gfc_add_block_to_block (&block, &lse->pre);
9180 gfc_add_block_to_block (&block, &rse->pre);
9182 gfc_add_modify (&block, lse->expr,
9183 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9186 gfc_add_block_to_block (&block, &lse->post);
9187 gfc_add_block_to_block (&block, &rse->post);
9189 return gfc_finish_block (&block);
9193 /* There are quite a lot of restrictions on the optimisation in using an
9194 array function assign without a temporary. */
9197 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9200 bool seen_array_ref;
9202 gfc_symbol *sym = expr1->symtree->n.sym;
9204 /* Play it safe with class functions assigned to a derived type. */
9205 if (gfc_is_class_array_function (expr2)
9206 && expr1->ts.type == BT_DERIVED)
9209 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9210 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9213 /* Elemental functions are scalarized so that they don't need a
9214 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9215 they would need special treatment in gfc_trans_arrayfunc_assign. */
9216 if (expr2->value.function.esym != NULL
9217 && expr2->value.function.esym->attr.elemental)
9220 /* Need a temporary if rhs is not FULL or a contiguous section. */
9221 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9224 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9225 if (gfc_ref_needs_temporary_p (expr1->ref))
9228 /* Functions returning pointers or allocatables need temporaries. */
9229 c = expr2->value.function.esym
9230 ? (expr2->value.function.esym->attr.pointer
9231 || expr2->value.function.esym->attr.allocatable)
9232 : (expr2->symtree->n.sym->attr.pointer
9233 || expr2->symtree->n.sym->attr.allocatable);
9237 /* Character array functions need temporaries unless the
9238 character lengths are the same. */
9239 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9241 if (expr1->ts.u.cl->length == NULL
9242 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9245 if (expr2->ts.u.cl->length == NULL
9246 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9249 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9250 expr2->ts.u.cl->length->value.integer) != 0)
9254 /* Check that no LHS component references appear during an array
9255 reference. This is needed because we do not have the means to
9256 span any arbitrary stride with an array descriptor. This check
9257 is not needed for the rhs because the function result has to be
9259 seen_array_ref = false;
9260 for (ref = expr1->ref; ref; ref = ref->next)
9262 if (ref->type == REF_ARRAY)
9263 seen_array_ref= true;
9264 else if (ref->type == REF_COMPONENT && seen_array_ref)
9268 /* Check for a dependency. */
9269 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9270 expr2->value.function.esym,
9271 expr2->value.function.actual,
9275 /* If we have reached here with an intrinsic function, we do not
9276 need a temporary except in the particular case that reallocation
9277 on assignment is active and the lhs is allocatable and a target. */
9278 if (expr2->value.function.isym)
9279 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9281 /* If the LHS is a dummy, we need a temporary if it is not
9283 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9286 /* If the lhs has been host_associated, is in common, a pointer or is
9287 a target and the function is not using a RESULT variable, aliasing
9288 can occur and a temporary is needed. */
9289 if ((sym->attr.host_assoc
9290 || sym->attr.in_common
9291 || sym->attr.pointer
9292 || sym->attr.cray_pointee
9293 || sym->attr.target)
9294 && expr2->symtree != NULL
9295 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9298 /* A PURE function can unconditionally be called without a temporary. */
9299 if (expr2->value.function.esym != NULL
9300 && expr2->value.function.esym->attr.pure)
9303 /* Implicit_pure functions are those which could legally be declared
9305 if (expr2->value.function.esym != NULL
9306 && expr2->value.function.esym->attr.implicit_pure)
9309 if (!sym->attr.use_assoc
9310 && !sym->attr.in_common
9311 && !sym->attr.pointer
9312 && !sym->attr.target
9313 && !sym->attr.cray_pointee
9314 && expr2->value.function.esym)
9316 /* A temporary is not needed if the function is not contained and
9317 the variable is local or host associated and not a pointer or
9319 if (!expr2->value.function.esym->attr.contained)
9322 /* A temporary is not needed if the lhs has never been host
9323 associated and the procedure is contained. */
9324 else if (!sym->attr.host_assoc)
9327 /* A temporary is not needed if the variable is local and not
9328 a pointer, a target or a result. */
9330 && expr2->value.function.esym->ns == sym->ns->parent)
9334 /* Default to temporary use. */
9339 /* Provide the loop info so that the lhs descriptor can be built for
9340 reallocatable assignments from extrinsic function calls. */
9343 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9346 /* Signal that the function call should not be made by
9347 gfc_conv_loop_setup. */
9348 se->ss->is_alloc_lhs = 1;
9349 gfc_init_loopinfo (loop);
9350 gfc_add_ss_to_loop (loop, *ss);
9351 gfc_add_ss_to_loop (loop, se->ss);
9352 gfc_conv_ss_startstride (loop);
9353 gfc_conv_loop_setup (loop, where);
9354 gfc_copy_loopinfo_to_se (se, loop);
9355 gfc_add_block_to_block (&se->pre, &loop->pre);
9356 gfc_add_block_to_block (&se->pre, &loop->post);
9357 se->ss->is_alloc_lhs = 0;
9361 /* For assignment to a reallocatable lhs from intrinsic functions,
9362 replace the se.expr (ie. the result) with a temporary descriptor.
9363 Null the data field so that the library allocates space for the
9364 result. Free the data of the original descriptor after the function,
9365 in case it appears in an argument expression and transfer the
9366 result to the original descriptor. */
9369 fcncall_realloc_result (gfc_se *se, int rank)
9378 /* Use the allocation done by the library. Substitute the lhs
9379 descriptor with a copy, whose data field is nulled.*/
9380 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9381 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9382 desc = build_fold_indirect_ref_loc (input_location, desc);
9384 /* Unallocated, the descriptor does not have a dtype. */
9385 tmp = gfc_conv_descriptor_dtype (desc);
9386 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9388 res_desc = gfc_evaluate_now (desc, &se->pre);
9389 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9390 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9392 /* Free the lhs after the function call and copy the result data to
9393 the lhs descriptor. */
9394 tmp = gfc_conv_descriptor_data_get (desc);
9395 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9396 logical_type_node, tmp,
9397 build_int_cst (TREE_TYPE (tmp), 0));
9398 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9399 tmp = gfc_call_free (tmp);
9400 gfc_add_expr_to_block (&se->post, tmp);
9402 tmp = gfc_conv_descriptor_data_get (res_desc);
9403 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9405 /* Check that the shapes are the same between lhs and expression. */
9406 for (n = 0 ; n < rank; n++)
9409 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9410 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9411 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9412 gfc_array_index_type, tmp, tmp1);
9413 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9414 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9415 gfc_array_index_type, tmp, tmp1);
9416 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9417 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9418 gfc_array_index_type, tmp, tmp1);
9419 tmp = fold_build2_loc (input_location, NE_EXPR,
9420 logical_type_node, tmp,
9421 gfc_index_zero_node);
9422 tmp = gfc_evaluate_now (tmp, &se->post);
9423 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9424 logical_type_node, tmp,
9428 /* 'zero_cond' being true is equal to lhs not being allocated or the
9429 shapes being different. */
9430 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9432 /* Now reset the bounds returned from the function call to bounds based
9433 on the lhs lbounds, except where the lhs is not allocated or the shapes
9434 of 'variable and 'expr' are different. Set the offset accordingly. */
9435 offset = gfc_index_zero_node;
9436 for (n = 0 ; n < rank; n++)
9440 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9441 lbound = fold_build3_loc (input_location, COND_EXPR,
9442 gfc_array_index_type, zero_cond,
9443 gfc_index_one_node, lbound);
9444 lbound = gfc_evaluate_now (lbound, &se->post);
9446 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9447 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9448 gfc_array_index_type, tmp, lbound);
9449 gfc_conv_descriptor_lbound_set (&se->post, desc,
9450 gfc_rank_cst[n], lbound);
9451 gfc_conv_descriptor_ubound_set (&se->post, desc,
9452 gfc_rank_cst[n], tmp);
9454 /* Set stride and accumulate the offset. */
9455 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9456 gfc_conv_descriptor_stride_set (&se->post, desc,
9457 gfc_rank_cst[n], tmp);
9458 tmp = fold_build2_loc (input_location, MULT_EXPR,
9459 gfc_array_index_type, lbound, tmp);
9460 offset = fold_build2_loc (input_location, MINUS_EXPR,
9461 gfc_array_index_type, offset, tmp);
9462 offset = gfc_evaluate_now (offset, &se->post);
9465 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9470 /* Try to translate array(:) = func (...), where func is a transformational
9471 array function, without using a temporary. Returns NULL if this isn't the
9475 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9479 gfc_component *comp = NULL;
9482 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9485 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9487 comp = gfc_get_proc_ptr_comp (expr2);
9489 if (!(expr2->value.function.isym
9490 || (comp && comp->attr.dimension)
9491 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9492 && expr2->value.function.esym->result->attr.dimension)))
9495 gfc_init_se (&se, NULL);
9496 gfc_start_block (&se.pre);
9497 se.want_pointer = 1;
9499 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9501 if (expr1->ts.type == BT_DERIVED
9502 && expr1->ts.u.derived->attr.alloc_comp)
9505 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9507 gfc_add_expr_to_block (&se.pre, tmp);
9510 se.direct_byref = 1;
9511 se.ss = gfc_walk_expr (expr2);
9512 gcc_assert (se.ss != gfc_ss_terminator);
9514 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9515 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9516 Clearly, this cannot be done for an allocatable function result, since
9517 the shape of the result is unknown and, in any case, the function must
9518 correctly take care of the reallocation internally. For intrinsic
9519 calls, the array data is freed and the library takes care of allocation.
9520 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9522 if (flag_realloc_lhs
9523 && gfc_is_reallocatable_lhs (expr1)
9524 && !gfc_expr_attr (expr1).codimension
9525 && !gfc_is_coindexed (expr1)
9526 && !(expr2->value.function.esym
9527 && expr2->value.function.esym->result->attr.allocatable))
9529 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9531 if (!expr2->value.function.isym)
9533 ss = gfc_walk_expr (expr1);
9534 gcc_assert (ss != gfc_ss_terminator);
9536 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9537 ss->is_alloc_lhs = 1;
9540 fcncall_realloc_result (&se, expr1->rank);
9543 gfc_conv_function_expr (&se, expr2);
9544 gfc_add_block_to_block (&se.pre, &se.post);
9547 gfc_cleanup_loop (&loop);
9549 gfc_free_ss_chain (se.ss);
9551 return gfc_finish_block (&se.pre);
9555 /* Try to efficiently translate array(:) = 0. Return NULL if this
9559 gfc_trans_zero_assign (gfc_expr * expr)
9561 tree dest, len, type;
9565 sym = expr->symtree->n.sym;
9566 dest = gfc_get_symbol_decl (sym);
9568 type = TREE_TYPE (dest);
9569 if (POINTER_TYPE_P (type))
9570 type = TREE_TYPE (type);
9571 if (!GFC_ARRAY_TYPE_P (type))
9574 /* Determine the length of the array. */
9575 len = GFC_TYPE_ARRAY_SIZE (type);
9576 if (!len || TREE_CODE (len) != INTEGER_CST)
9579 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9580 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9581 fold_convert (gfc_array_index_type, tmp));
9583 /* If we are zeroing a local array avoid taking its address by emitting
9585 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9586 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9587 dest, build_constructor (TREE_TYPE (dest),
9590 /* Convert arguments to the correct types. */
9591 dest = fold_convert (pvoid_type_node, dest);
9592 len = fold_convert (size_type_node, len);
9594 /* Construct call to __builtin_memset. */
9595 tmp = build_call_expr_loc (input_location,
9596 builtin_decl_explicit (BUILT_IN_MEMSET),
9597 3, dest, integer_zero_node, len);
9598 return fold_convert (void_type_node, tmp);
9602 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9603 that constructs the call to __builtin_memcpy. */
9606 gfc_build_memcpy_call (tree dst, tree src, tree len)
9610 /* Convert arguments to the correct types. */
9611 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9612 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9614 dst = fold_convert (pvoid_type_node, dst);
9616 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9617 src = gfc_build_addr_expr (pvoid_type_node, src);
9619 src = fold_convert (pvoid_type_node, src);
9621 len = fold_convert (size_type_node, len);
9623 /* Construct call to __builtin_memcpy. */
9624 tmp = build_call_expr_loc (input_location,
9625 builtin_decl_explicit (BUILT_IN_MEMCPY),
9627 return fold_convert (void_type_node, tmp);
9631 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9632 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9633 source/rhs, both are gfc_full_array_ref_p which have been checked for
9637 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9639 tree dst, dlen, dtype;
9640 tree src, slen, stype;
9643 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9644 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9646 dtype = TREE_TYPE (dst);
9647 if (POINTER_TYPE_P (dtype))
9648 dtype = TREE_TYPE (dtype);
9649 stype = TREE_TYPE (src);
9650 if (POINTER_TYPE_P (stype))
9651 stype = TREE_TYPE (stype);
9653 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9656 /* Determine the lengths of the arrays. */
9657 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9658 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9660 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9661 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9662 dlen, fold_convert (gfc_array_index_type, tmp));
9664 slen = GFC_TYPE_ARRAY_SIZE (stype);
9665 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9667 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9668 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9669 slen, fold_convert (gfc_array_index_type, tmp));
9671 /* Sanity check that they are the same. This should always be
9672 the case, as we should already have checked for conformance. */
9673 if (!tree_int_cst_equal (slen, dlen))
9676 return gfc_build_memcpy_call (dst, src, dlen);
9680 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9681 this can't be done. EXPR1 is the destination/lhs for which
9682 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9685 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9687 unsigned HOST_WIDE_INT nelem;
9693 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9697 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9698 dtype = TREE_TYPE (dst);
9699 if (POINTER_TYPE_P (dtype))
9700 dtype = TREE_TYPE (dtype);
9701 if (!GFC_ARRAY_TYPE_P (dtype))
9704 /* Determine the lengths of the array. */
9705 len = GFC_TYPE_ARRAY_SIZE (dtype);
9706 if (!len || TREE_CODE (len) != INTEGER_CST)
9709 /* Confirm that the constructor is the same size. */
9710 if (compare_tree_int (len, nelem) != 0)
9713 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9714 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9715 fold_convert (gfc_array_index_type, tmp));
9717 stype = gfc_typenode_for_spec (&expr2->ts);
9718 src = gfc_build_constant_array_constructor (expr2, stype);
9720 stype = TREE_TYPE (src);
9721 if (POINTER_TYPE_P (stype))
9722 stype = TREE_TYPE (stype);
9724 return gfc_build_memcpy_call (dst, src, len);
9728 /* Tells whether the expression is to be treated as a variable reference. */
9731 gfc_expr_is_variable (gfc_expr *expr)
9734 gfc_component *comp;
9735 gfc_symbol *func_ifc;
9737 if (expr->expr_type == EXPR_VARIABLE)
9740 arg = gfc_get_noncopying_intrinsic_argument (expr);
9743 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9744 return gfc_expr_is_variable (arg);
9747 /* A data-pointer-returning function should be considered as a variable
9749 if (expr->expr_type == EXPR_FUNCTION
9750 && expr->ref == NULL)
9752 if (expr->value.function.isym != NULL)
9755 if (expr->value.function.esym != NULL)
9757 func_ifc = expr->value.function.esym;
9762 gcc_assert (expr->symtree);
9763 func_ifc = expr->symtree->n.sym;
9770 comp = gfc_get_proc_ptr_comp (expr);
9771 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9774 func_ifc = comp->ts.interface;
9778 if (expr->expr_type == EXPR_COMPCALL)
9780 gcc_assert (!expr->value.compcall.tbp->is_generic);
9781 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9788 gcc_assert (func_ifc->attr.function
9789 && func_ifc->result != NULL);
9790 return func_ifc->result->attr.pointer;
9794 /* Is the lhs OK for automatic reallocation? */
9797 is_scalar_reallocatable_lhs (gfc_expr *expr)
9801 /* An allocatable variable with no reference. */
9802 if (expr->symtree->n.sym->attr.allocatable
9806 /* All that can be left are allocatable components. However, we do
9807 not check for allocatable components here because the expression
9808 could be an allocatable component of a pointer component. */
9809 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9810 && expr->symtree->n.sym->ts.type != BT_CLASS)
9813 /* Find an allocatable component ref last. */
9814 for (ref = expr->ref; ref; ref = ref->next)
9815 if (ref->type == REF_COMPONENT
9817 && ref->u.c.component->attr.allocatable)
9824 /* Allocate or reallocate scalar lhs, as necessary. */
9827 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9842 if (!expr1 || expr1->rank)
9845 if (!expr2 || expr2->rank)
9848 for (ref = expr1->ref; ref; ref = ref->next)
9849 if (ref->type == REF_SUBSTRING)
9852 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9854 /* Since this is a scalar lhs, we can afford to do this. That is,
9855 there is no risk of side effects being repeated. */
9856 gfc_init_se (&lse, NULL);
9857 lse.want_pointer = 1;
9858 gfc_conv_expr (&lse, expr1);
9860 jump_label1 = gfc_build_label_decl (NULL_TREE);
9861 jump_label2 = gfc_build_label_decl (NULL_TREE);
9863 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9864 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9865 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9867 tmp = build3_v (COND_EXPR, cond,
9868 build1_v (GOTO_EXPR, jump_label1),
9869 build_empty_stmt (input_location));
9870 gfc_add_expr_to_block (block, tmp);
9872 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9874 /* Use the rhs string length and the lhs element size. */
9875 size = string_length;
9876 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9877 tmp = TYPE_SIZE_UNIT (tmp);
9878 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9879 TREE_TYPE (tmp), tmp,
9880 fold_convert (TREE_TYPE (tmp), size));
9884 /* Otherwise use the length in bytes of the rhs. */
9885 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9886 size_in_bytes = size;
9889 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9890 size_in_bytes, size_one_node);
9892 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9894 tree caf_decl, token;
9896 symbol_attribute attr;
9898 gfc_clear_attr (&attr);
9899 gfc_init_se (&caf_se, NULL);
9901 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9902 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9904 gfc_add_block_to_block (block, &caf_se.pre);
9905 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9906 gfc_build_addr_expr (NULL_TREE, token),
9907 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9910 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9912 tmp = build_call_expr_loc (input_location,
9913 builtin_decl_explicit (BUILT_IN_CALLOC),
9914 2, build_one_cst (size_type_node),
9916 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9917 gfc_add_modify (block, lse.expr, tmp);
9921 tmp = build_call_expr_loc (input_location,
9922 builtin_decl_explicit (BUILT_IN_MALLOC),
9924 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9925 gfc_add_modify (block, lse.expr, tmp);
9928 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9930 /* Deferred characters need checking for lhs and rhs string
9931 length. Other deferred parameter variables will have to
9933 tmp = build1_v (GOTO_EXPR, jump_label2);
9934 gfc_add_expr_to_block (block, tmp);
9936 tmp = build1_v (LABEL_EXPR, jump_label1);
9937 gfc_add_expr_to_block (block, tmp);
9939 /* For a deferred length character, reallocate if lengths of lhs and
9940 rhs are different. */
9941 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9943 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9945 fold_convert (TREE_TYPE (lse.string_length),
9947 /* Jump past the realloc if the lengths are the same. */
9948 tmp = build3_v (COND_EXPR, cond,
9949 build1_v (GOTO_EXPR, jump_label2),
9950 build_empty_stmt (input_location));
9951 gfc_add_expr_to_block (block, tmp);
9952 tmp = build_call_expr_loc (input_location,
9953 builtin_decl_explicit (BUILT_IN_REALLOC),
9954 2, fold_convert (pvoid_type_node, lse.expr),
9956 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9957 gfc_add_modify (block, lse.expr, tmp);
9958 tmp = build1_v (LABEL_EXPR, jump_label2);
9959 gfc_add_expr_to_block (block, tmp);
9961 /* Update the lhs character length. */
9962 size = string_length;
9963 gfc_add_modify (block, lse.string_length,
9964 fold_convert (TREE_TYPE (lse.string_length), size));
9968 /* Check for assignments of the type
9972 to make sure we do not check for reallocation unneccessarily. */
9976 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9978 gfc_actual_arglist *a;
9981 switch (expr2->expr_type)
9984 return gfc_dep_compare_expr (expr1, expr2) == 0;
9987 if (expr2->value.function.esym
9988 && expr2->value.function.esym->attr.elemental)
9990 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9993 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9998 else if (expr2->value.function.isym
9999 && expr2->value.function.isym->elemental)
10001 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10004 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10013 switch (expr2->value.op.op)
10015 case INTRINSIC_NOT:
10016 case INTRINSIC_UPLUS:
10017 case INTRINSIC_UMINUS:
10018 case INTRINSIC_PARENTHESES:
10019 return is_runtime_conformable (expr1, expr2->value.op.op1);
10021 case INTRINSIC_PLUS:
10022 case INTRINSIC_MINUS:
10023 case INTRINSIC_TIMES:
10024 case INTRINSIC_DIVIDE:
10025 case INTRINSIC_POWER:
10026 case INTRINSIC_AND:
10028 case INTRINSIC_EQV:
10029 case INTRINSIC_NEQV:
10036 case INTRINSIC_EQ_OS:
10037 case INTRINSIC_NE_OS:
10038 case INTRINSIC_GT_OS:
10039 case INTRINSIC_GE_OS:
10040 case INTRINSIC_LT_OS:
10041 case INTRINSIC_LE_OS:
10043 e1 = expr2->value.op.op1;
10044 e2 = expr2->value.op.op2;
10046 if (e1->rank == 0 && e2->rank > 0)
10047 return is_runtime_conformable (expr1, e2);
10048 else if (e1->rank > 0 && e2->rank == 0)
10049 return is_runtime_conformable (expr1, e1);
10050 else if (e1->rank > 0 && e2->rank > 0)
10051 return is_runtime_conformable (expr1, e1)
10052 && is_runtime_conformable (expr1, e2);
10070 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10071 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10072 bool class_realloc)
10074 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10075 vec<tree, va_gc> *args = NULL;
10077 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10080 /* Generate allocation of the lhs. */
10086 tmp = gfc_vptr_size_get (vptr);
10087 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10088 ? gfc_class_data_get (lse->expr) : lse->expr;
10089 gfc_init_block (&alloc);
10090 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10091 tmp = fold_build2_loc (input_location, EQ_EXPR,
10092 logical_type_node, class_han,
10093 build_int_cst (prvoid_type_node, 0));
10094 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10096 PRED_FORTRAN_FAIL_ALLOC),
10097 gfc_finish_block (&alloc),
10098 build_empty_stmt (input_location));
10099 gfc_add_expr_to_block (&lse->pre, tmp);
10102 fcn = gfc_vptr_copy_get (vptr);
10104 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10105 ? gfc_class_data_get (rse->expr) : rse->expr;
10108 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10109 || INDIRECT_REF_P (tmp)
10110 || (rhs->ts.type == BT_DERIVED
10111 && rhs->ts.u.derived->attr.unlimited_polymorphic
10112 && !rhs->ts.u.derived->attr.pointer
10113 && !rhs->ts.u.derived->attr.allocatable)
10114 || (UNLIMITED_POLY (rhs)
10115 && !CLASS_DATA (rhs)->attr.pointer
10116 && !CLASS_DATA (rhs)->attr.allocatable))
10117 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10119 vec_safe_push (args, tmp);
10120 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10121 ? gfc_class_data_get (lse->expr) : lse->expr;
10122 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10123 || INDIRECT_REF_P (tmp)
10124 || (lhs->ts.type == BT_DERIVED
10125 && lhs->ts.u.derived->attr.unlimited_polymorphic
10126 && !lhs->ts.u.derived->attr.pointer
10127 && !lhs->ts.u.derived->attr.allocatable)
10128 || (UNLIMITED_POLY (lhs)
10129 && !CLASS_DATA (lhs)->attr.pointer
10130 && !CLASS_DATA (lhs)->attr.allocatable))
10131 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10133 vec_safe_push (args, tmp);
10135 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10137 if (to_len != NULL_TREE && !integer_zerop (from_len))
10140 vec_safe_push (args, from_len);
10141 vec_safe_push (args, to_len);
10142 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10144 tmp = fold_build2_loc (input_location, GT_EXPR,
10145 logical_type_node, from_len,
10146 build_zero_cst (TREE_TYPE (from_len)));
10147 return fold_build3_loc (input_location, COND_EXPR,
10148 void_type_node, tmp,
10156 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10157 ? gfc_class_data_get (lse->expr) : lse->expr;
10158 stmtblock_t tblock;
10159 gfc_init_block (&tblock);
10160 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10161 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10162 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10163 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10164 /* When coming from a ptr_copy lhs and rhs are swapped. */
10165 gfc_add_modify_loc (input_location, &tblock, rhst,
10166 fold_convert (TREE_TYPE (rhst), tmp));
10167 return gfc_finish_block (&tblock);
10171 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10172 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10173 init_flag indicates initialization expressions and dealloc that no
10174 deallocate prior assignment is needed (if in doubt, set true).
10175 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10176 routine instead of a pointer assignment. Alias resolution is only done,
10177 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10178 where it is known, that newly allocated memory on the lhs can never be
10179 an alias of the rhs. */
10182 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10183 bool dealloc, bool use_vptr_copy, bool may_alias)
10188 gfc_ss *lss_section;
10195 bool scalar_to_array;
10196 tree string_length;
10198 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10199 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10200 bool is_poly_assign;
10202 /* Assignment of the form lhs = rhs. */
10203 gfc_start_block (&block);
10205 gfc_init_se (&lse, NULL);
10206 gfc_init_se (&rse, NULL);
10208 /* Walk the lhs. */
10209 lss = gfc_walk_expr (expr1);
10210 if (gfc_is_reallocatable_lhs (expr1))
10212 lss->no_bounds_check = 1;
10213 if (!(expr2->expr_type == EXPR_FUNCTION
10214 && expr2->value.function.isym != NULL
10215 && !(expr2->value.function.isym->elemental
10216 || expr2->value.function.isym->conversion)))
10217 lss->is_alloc_lhs = 1;
10220 lss->no_bounds_check = expr1->no_bounds_check;
10224 if ((expr1->ts.type == BT_DERIVED)
10225 && (gfc_is_class_array_function (expr2)
10226 || gfc_is_alloc_class_scalar_function (expr2)))
10227 expr2->must_finalize = 1;
10229 /* Checking whether a class assignment is desired is quite complicated and
10230 needed at two locations, so do it once only before the information is
10232 lhs_attr = gfc_expr_attr (expr1);
10233 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10234 || (lhs_attr.allocatable && !lhs_attr.dimension))
10235 && (expr1->ts.type == BT_CLASS
10236 || gfc_is_class_array_ref (expr1, NULL)
10237 || gfc_is_class_scalar_expr (expr1)
10238 || gfc_is_class_array_ref (expr2, NULL)
10239 || gfc_is_class_scalar_expr (expr2));
10242 /* Only analyze the expressions for coarray properties, when in coarray-lib
10244 if (flag_coarray == GFC_FCOARRAY_LIB)
10246 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10247 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10250 if (lss != gfc_ss_terminator)
10252 /* The assignment needs scalarization. */
10255 /* Find a non-scalar SS from the lhs. */
10256 while (lss_section != gfc_ss_terminator
10257 && lss_section->info->type != GFC_SS_SECTION)
10258 lss_section = lss_section->next;
10260 gcc_assert (lss_section != gfc_ss_terminator);
10262 /* Initialize the scalarizer. */
10263 gfc_init_loopinfo (&loop);
10265 /* Walk the rhs. */
10266 rss = gfc_walk_expr (expr2);
10267 if (rss == gfc_ss_terminator)
10268 /* The rhs is scalar. Add a ss for the expression. */
10269 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10270 /* When doing a class assign, then the handle to the rhs needs to be a
10271 pointer to allow for polymorphism. */
10272 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10273 rss->info->type = GFC_SS_REFERENCE;
10275 rss->no_bounds_check = expr2->no_bounds_check;
10276 /* Associate the SS with the loop. */
10277 gfc_add_ss_to_loop (&loop, lss);
10278 gfc_add_ss_to_loop (&loop, rss);
10280 /* Calculate the bounds of the scalarization. */
10281 gfc_conv_ss_startstride (&loop);
10282 /* Enable loop reversal. */
10283 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10284 loop.reverse[n] = GFC_ENABLE_REVERSE;
10285 /* Resolve any data dependencies in the statement. */
10287 gfc_conv_resolve_dependencies (&loop, lss, rss);
10288 /* Setup the scalarizing loops. */
10289 gfc_conv_loop_setup (&loop, &expr2->where);
10291 /* Setup the gfc_se structures. */
10292 gfc_copy_loopinfo_to_se (&lse, &loop);
10293 gfc_copy_loopinfo_to_se (&rse, &loop);
10296 gfc_mark_ss_chain_used (rss, 1);
10297 if (loop.temp_ss == NULL)
10300 gfc_mark_ss_chain_used (lss, 1);
10304 lse.ss = loop.temp_ss;
10305 gfc_mark_ss_chain_used (lss, 3);
10306 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10309 /* Allow the scalarizer to workshare array assignments. */
10310 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10311 == OMPWS_WORKSHARE_FLAG
10312 && loop.temp_ss == NULL)
10314 maybe_workshare = true;
10315 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10318 /* Start the scalarized loop body. */
10319 gfc_start_scalarized_body (&loop, &body);
10322 gfc_init_block (&body);
10324 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10326 /* Translate the expression. */
10327 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10328 && lhs_caf_attr.codimension;
10329 gfc_conv_expr (&rse, expr2);
10331 /* Deal with the case of a scalar class function assigned to a derived type. */
10332 if (gfc_is_alloc_class_scalar_function (expr2)
10333 && expr1->ts.type == BT_DERIVED)
10335 rse.expr = gfc_class_data_get (rse.expr);
10336 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10339 /* Stabilize a string length for temporaries. */
10340 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10341 && !(VAR_P (rse.string_length)
10342 || TREE_CODE (rse.string_length) == PARM_DECL
10343 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10344 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10345 else if (expr2->ts.type == BT_CHARACTER)
10347 if (expr1->ts.deferred && gfc_check_dependency (expr1, expr2, true))
10348 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10349 string_length = rse.string_length;
10352 string_length = NULL_TREE;
10356 gfc_conv_tmp_array_ref (&lse);
10357 if (expr2->ts.type == BT_CHARACTER)
10358 lse.string_length = string_length;
10362 gfc_conv_expr (&lse, expr1);
10363 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10365 && gfc_expr_attr (expr1).allocatable
10372 tmp = INDIRECT_REF_P (lse.expr)
10373 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10375 /* We should only get array references here. */
10376 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10377 || TREE_CODE (tmp) == ARRAY_REF);
10379 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10380 or the array itself(ARRAY_REF). */
10381 tmp = TREE_OPERAND (tmp, 0);
10383 /* Provide the address of the array. */
10384 if (TREE_CODE (lse.expr) == ARRAY_REF)
10385 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10387 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10388 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10389 msg = _("Assignment of scalar to unallocated array");
10390 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10391 &expr1->where, msg);
10394 /* Deallocate the lhs parameterized components if required. */
10395 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10396 && !expr1->symtree->n.sym->attr.associate_var)
10398 if (expr1->ts.type == BT_DERIVED
10399 && expr1->ts.u.derived
10400 && expr1->ts.u.derived->attr.pdt_type)
10402 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10404 gfc_add_expr_to_block (&lse.pre, tmp);
10406 else if (expr1->ts.type == BT_CLASS
10407 && CLASS_DATA (expr1)->ts.u.derived
10408 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10410 tmp = gfc_class_data_get (lse.expr);
10411 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10413 gfc_add_expr_to_block (&lse.pre, tmp);
10418 /* Assignments of scalar derived types with allocatable components
10419 to arrays must be done with a deep copy and the rhs temporary
10420 must have its components deallocated afterwards. */
10421 scalar_to_array = (expr2->ts.type == BT_DERIVED
10422 && expr2->ts.u.derived->attr.alloc_comp
10423 && !gfc_expr_is_variable (expr2)
10424 && expr1->rank && !expr2->rank);
10425 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10427 && expr1->ts.u.derived->attr.alloc_comp
10428 && gfc_is_alloc_class_scalar_function (expr2));
10429 if (scalar_to_array && dealloc)
10431 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10432 gfc_prepend_expr_to_block (&loop.post, tmp);
10435 /* When assigning a character function result to a deferred-length variable,
10436 the function call must happen before the (re)allocation of the lhs -
10437 otherwise the character length of the result is not known.
10438 NOTE 1: This relies on having the exact dependence of the length type
10439 parameter available to the caller; gfortran saves it in the .mod files.
10440 NOTE 2: Vector array references generate an index temporary that must
10441 not go outside the loop. Otherwise, variables should not generate
10443 NOTE 3: The concatenation operation generates a temporary pointer,
10444 whose allocation must go to the innermost loop.
10445 NOTE 4: Elemental functions may generate a temporary, too. */
10446 if (flag_realloc_lhs
10447 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10448 && !(lss != gfc_ss_terminator
10449 && rss != gfc_ss_terminator
10450 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10451 || (expr2->expr_type == EXPR_FUNCTION
10452 && expr2->value.function.esym != NULL
10453 && expr2->value.function.esym->attr.elemental)
10454 || (expr2->expr_type == EXPR_FUNCTION
10455 && expr2->value.function.isym != NULL
10456 && expr2->value.function.isym->elemental)
10457 || (expr2->expr_type == EXPR_OP
10458 && expr2->value.op.op == INTRINSIC_CONCAT))))
10459 gfc_add_block_to_block (&block, &rse.pre);
10461 /* Nullify the allocatable components corresponding to those of the lhs
10462 derived type, so that the finalization of the function result does not
10463 affect the lhs of the assignment. Prepend is used to ensure that the
10464 nullification occurs before the call to the finalizer. In the case of
10465 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10466 as part of the deep copy. */
10467 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10468 && (gfc_is_class_array_function (expr2)
10469 || gfc_is_alloc_class_scalar_function (expr2)))
10472 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10473 gfc_prepend_expr_to_block (&rse.post, tmp);
10474 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10475 gfc_add_block_to_block (&loop.post, &rse.post);
10480 if (is_poly_assign)
10481 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10482 use_vptr_copy || (lhs_attr.allocatable
10483 && !lhs_attr.dimension),
10484 flag_realloc_lhs && !lhs_attr.pointer);
10485 else if (flag_coarray == GFC_FCOARRAY_LIB
10486 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10487 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10488 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10490 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10491 allocatable component, because those need to be accessed via the
10492 caf-runtime. No need to check for coindexes here, because resolve
10493 has rewritten those already. */
10495 gfc_actual_arglist a1, a2;
10496 /* Clear the structures to prevent accessing garbage. */
10497 memset (&code, '\0', sizeof (gfc_code));
10498 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10499 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10504 code.ext.actual = &a1;
10505 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10506 tmp = gfc_conv_intrinsic_subroutine (&code);
10508 else if (!is_poly_assign && expr2->must_finalize
10509 && expr1->ts.type == BT_CLASS
10510 && expr2->ts.type == BT_CLASS)
10512 /* This case comes about when the scalarizer provides array element
10513 references. Use the vptr copy function, since this does a deep
10514 copy of allocatable components, without which the finalizer call */
10515 tmp = gfc_get_vptr_from_expr (rse.expr);
10516 if (tmp != NULL_TREE)
10518 tree fcn = gfc_vptr_copy_get (tmp);
10519 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10520 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10521 tmp = build_call_expr_loc (input_location,
10523 gfc_build_addr_expr (NULL, rse.expr),
10524 gfc_build_addr_expr (NULL, lse.expr));
10528 /* If nothing else works, do it the old fashioned way! */
10529 if (tmp == NULL_TREE)
10530 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10531 gfc_expr_is_variable (expr2)
10533 || expr2->expr_type == EXPR_ARRAY,
10534 !(l_is_temp || init_flag) && dealloc,
10535 expr1->symtree->n.sym->attr.codimension);
10537 /* Add the pre blocks to the body. */
10538 gfc_add_block_to_block (&body, &rse.pre);
10539 gfc_add_block_to_block (&body, &lse.pre);
10540 gfc_add_expr_to_block (&body, tmp);
10541 /* Add the post blocks to the body. */
10542 gfc_add_block_to_block (&body, &rse.post);
10543 gfc_add_block_to_block (&body, &lse.post);
10545 if (lss == gfc_ss_terminator)
10547 /* F2003: Add the code for reallocation on assignment. */
10548 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10549 && !is_poly_assign)
10550 alloc_scalar_allocatable_for_assignment (&block, string_length,
10553 /* Use the scalar assignment as is. */
10554 gfc_add_block_to_block (&block, &body);
10558 gcc_assert (lse.ss == gfc_ss_terminator
10559 && rse.ss == gfc_ss_terminator);
10563 gfc_trans_scalarized_loop_boundary (&loop, &body);
10565 /* We need to copy the temporary to the actual lhs. */
10566 gfc_init_se (&lse, NULL);
10567 gfc_init_se (&rse, NULL);
10568 gfc_copy_loopinfo_to_se (&lse, &loop);
10569 gfc_copy_loopinfo_to_se (&rse, &loop);
10571 rse.ss = loop.temp_ss;
10574 gfc_conv_tmp_array_ref (&rse);
10575 gfc_conv_expr (&lse, expr1);
10577 gcc_assert (lse.ss == gfc_ss_terminator
10578 && rse.ss == gfc_ss_terminator);
10580 if (expr2->ts.type == BT_CHARACTER)
10581 rse.string_length = string_length;
10583 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10585 gfc_add_expr_to_block (&body, tmp);
10588 /* F2003: Allocate or reallocate lhs of allocatable array. */
10589 if (flag_realloc_lhs
10590 && gfc_is_reallocatable_lhs (expr1)
10592 && !is_runtime_conformable (expr1, expr2))
10594 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10595 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10596 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10597 if (tmp != NULL_TREE)
10598 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10601 if (maybe_workshare)
10602 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10604 /* Generate the copying loops. */
10605 gfc_trans_scalarizing_loops (&loop, &body);
10607 /* Wrap the whole thing up. */
10608 gfc_add_block_to_block (&block, &loop.pre);
10609 gfc_add_block_to_block (&block, &loop.post);
10611 gfc_cleanup_loop (&loop);
10614 return gfc_finish_block (&block);
10618 /* Check whether EXPR is a copyable array. */
10621 copyable_array_p (gfc_expr * expr)
10623 if (expr->expr_type != EXPR_VARIABLE)
10626 /* First check it's an array. */
10627 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10630 if (!gfc_full_array_ref_p (expr->ref, NULL))
10633 /* Next check that it's of a simple enough type. */
10634 switch (expr->ts.type)
10646 return !expr->ts.u.derived->attr.alloc_comp;
10655 /* Translate an assignment. */
10658 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10659 bool dealloc, bool use_vptr_copy, bool may_alias)
10663 /* Special case a single function returning an array. */
10664 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10666 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10671 /* Special case assigning an array to zero. */
10672 if (copyable_array_p (expr1)
10673 && is_zero_initializer_p (expr2))
10675 tmp = gfc_trans_zero_assign (expr1);
10680 /* Special case copying one array to another. */
10681 if (copyable_array_p (expr1)
10682 && copyable_array_p (expr2)
10683 && gfc_compare_types (&expr1->ts, &expr2->ts)
10684 && !gfc_check_dependency (expr1, expr2, 0))
10686 tmp = gfc_trans_array_copy (expr1, expr2);
10691 /* Special case initializing an array from a constant array constructor. */
10692 if (copyable_array_p (expr1)
10693 && expr2->expr_type == EXPR_ARRAY
10694 && gfc_compare_types (&expr1->ts, &expr2->ts))
10696 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10701 if (UNLIMITED_POLY (expr1) && expr1->rank
10702 && expr2->ts.type != BT_CLASS)
10703 use_vptr_copy = true;
10705 /* Fallback to the scalarizer to generate explicit loops. */
10706 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10707 use_vptr_copy, may_alias);
10711 gfc_trans_init_assign (gfc_code * code)
10713 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10717 gfc_trans_assign (gfc_code * code)
10719 return gfc_trans_assignment (code->expr1, code->expr2, false, true);