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, bool is_mold)
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)
398 base_expr = gfc_expr_to_initialize (e);
400 base_expr = gfc_copy_expr (e);
402 /* Restore the original tail expression. */
405 gfc_free_ref_list (class_ref->next);
406 class_ref->next = tail;
408 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
410 gfc_free_ref_list (e->ref);
417 /* Reset the vptr to the declared type, e.g. after deallocation. */
420 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
427 /* Evaluate the expression and obtain the vptr from it. */
428 gfc_init_se (&se, NULL);
430 gfc_conv_expr_descriptor (&se, e);
432 gfc_conv_expr (&se, e);
433 gfc_add_block_to_block (block, &se.pre);
434 vptr = gfc_get_vptr_from_expr (se.expr);
436 /* If a vptr is not found, we can do nothing more. */
437 if (vptr == NULL_TREE)
440 if (UNLIMITED_POLY (e))
441 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
444 /* Return the vptr to the address of the declared type. */
445 vtab = gfc_find_derived_vtab (e->ts.u.derived);
446 vtable = vtab->backend_decl;
447 if (vtable == NULL_TREE)
448 vtable = gfc_get_symbol_decl (vtab);
449 vtable = gfc_build_addr_expr (NULL, vtable);
450 vtable = fold_convert (TREE_TYPE (vptr), vtable);
451 gfc_add_modify (block, vptr, vtable);
456 /* Reset the len for unlimited polymorphic objects. */
459 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
463 e = gfc_find_and_cut_at_last_class_ref (expr);
466 gfc_add_len_component (e);
467 gfc_init_se (&se_len, NULL);
468 gfc_conv_expr (&se_len, e);
469 gfc_add_modify (block, se_len.expr,
470 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
475 /* Obtain the vptr of the last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_vptr_from_expr (tree expr)
484 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
486 type = TREE_TYPE (tmp);
489 if (GFC_CLASS_TYPE_P (type))
490 return gfc_class_vptr_get (tmp);
491 if (type != TYPE_CANONICAL (type))
492 type = TYPE_CANONICAL (type);
496 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
500 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
501 tmp = build_fold_indirect_ref_loc (input_location, tmp);
503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
504 return gfc_class_vptr_get (tmp);
511 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
514 tree tmp, tmp2, type;
516 gfc_conv_descriptor_data_set (block, lhs_desc,
517 gfc_conv_descriptor_data_get (rhs_desc));
518 gfc_conv_descriptor_offset_set (block, lhs_desc,
519 gfc_conv_descriptor_offset_get (rhs_desc));
521 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
522 gfc_conv_descriptor_dtype (rhs_desc));
524 /* Assign the dimension as range-ref. */
525 tmp = gfc_get_descriptor_dimension (lhs_desc);
526 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
528 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
529 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
530 gfc_index_zero_node, NULL_TREE, NULL_TREE);
531 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
532 gfc_index_zero_node, NULL_TREE, NULL_TREE);
533 gfc_add_modify (block, tmp, tmp2);
537 /* Takes a derived type expression and returns the address of a temporary
538 class object of the 'declared' type. If vptr is not NULL, this is
539 used for the temporary class object.
540 optional_alloc_ptr is false when the dummy is neither allocatable
541 nor a pointer; that's only relevant for the optional handling. */
543 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
544 gfc_typespec class_ts, tree vptr, bool optional,
545 bool optional_alloc_ptr)
548 tree cond_optional = NULL_TREE;
555 /* The derived type needs to be converted to a temporary
557 tmp = gfc_typenode_for_spec (&class_ts);
558 var = gfc_create_var (tmp, "class");
561 ctree = gfc_class_vptr_get (var);
563 if (vptr != NULL_TREE)
565 /* Use the dynamic vptr. */
570 /* In this case the vtab corresponds to the derived type and the
571 vptr must point to it. */
572 vtab = gfc_find_derived_vtab (e->ts.u.derived);
574 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
576 gfc_add_modify (&parmse->pre, ctree,
577 fold_convert (TREE_TYPE (ctree), tmp));
579 /* Now set the data field. */
580 ctree = gfc_class_data_get (var);
583 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
585 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
587 /* If there is a ready made pointer to a derived type, use it
588 rather than evaluating the expression again. */
589 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
590 gfc_add_modify (&parmse->pre, ctree, tmp);
592 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
594 /* For an array reference in an elemental procedure call we need
595 to retain the ss to provide the scalarized array reference. */
596 gfc_conv_expr_reference (parmse, e);
597 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
599 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
601 fold_convert (TREE_TYPE (tmp), null_pointer_node));
602 gfc_add_modify (&parmse->pre, ctree, tmp);
606 ss = gfc_walk_expr (e);
607 if (ss == gfc_ss_terminator)
610 gfc_conv_expr_reference (parmse, e);
612 /* Scalar to an assumed-rank array. */
613 if (class_ts.u.derived->components->as)
616 type = get_scalar_to_descriptor_type (parmse->expr,
618 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
619 gfc_get_dtype (type));
621 parmse->expr = build3_loc (input_location, COND_EXPR,
622 TREE_TYPE (parmse->expr),
623 cond_optional, parmse->expr,
624 fold_convert (TREE_TYPE (parmse->expr),
626 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
630 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
632 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
634 fold_convert (TREE_TYPE (tmp),
636 gfc_add_modify (&parmse->pre, ctree, tmp);
642 gfc_init_block (&block);
646 parmse->use_offset = 1;
647 gfc_conv_expr_descriptor (parmse, e);
649 /* Detect any array references with vector subscripts. */
650 for (ref = e->ref; ref; ref = ref->next)
651 if (ref->type == REF_ARRAY
652 && ref->u.ar.type != AR_ELEMENT
653 && ref->u.ar.type != AR_FULL)
655 for (dim = 0; dim < ref->u.ar.dimen; dim++)
656 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
658 if (dim < ref->u.ar.dimen)
662 /* Array references with vector subscripts and non-variable expressions
663 need be converted to a one-based descriptor. */
664 if (ref || e->expr_type != EXPR_VARIABLE)
666 for (dim = 0; dim < e->rank; ++dim)
667 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
671 if (e->rank != class_ts.u.derived->components->as->rank)
673 gcc_assert (class_ts.u.derived->components->as->type
675 class_array_data_assign (&block, ctree, parmse->expr, false);
679 if (gfc_expr_attr (e).codimension)
680 parmse->expr = fold_build1_loc (input_location,
684 gfc_add_modify (&block, ctree, parmse->expr);
689 tmp = gfc_finish_block (&block);
691 gfc_init_block (&block);
692 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
694 tmp = build3_v (COND_EXPR, cond_optional, tmp,
695 gfc_finish_block (&block));
696 gfc_add_expr_to_block (&parmse->pre, tmp);
699 gfc_add_block_to_block (&parmse->pre, &block);
703 if (class_ts.u.derived->components->ts.type == BT_DERIVED
704 && class_ts.u.derived->components->ts.u.derived
705 ->attr.unlimited_polymorphic)
707 /* Take care about initializing the _len component correctly. */
708 ctree = gfc_class_len_get (var);
709 if (UNLIMITED_POLY (e))
714 len = gfc_copy_expr (e);
715 gfc_add_len_component (len);
716 gfc_init_se (&se, NULL);
717 gfc_conv_expr (&se, len);
719 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
720 cond_optional, se.expr,
721 fold_convert (TREE_TYPE (se.expr),
727 tmp = integer_zero_node;
728 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
731 /* Pass the address of the class object. */
732 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
734 if (optional && optional_alloc_ptr)
735 parmse->expr = build3_loc (input_location, COND_EXPR,
736 TREE_TYPE (parmse->expr),
737 cond_optional, parmse->expr,
738 fold_convert (TREE_TYPE (parmse->expr),
743 /* Create a new class container, which is required as scalar coarrays
744 have an array descriptor while normal scalars haven't. Optionally,
745 NULL pointer checks are added if the argument is OPTIONAL. */
748 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
749 gfc_typespec class_ts, bool optional)
751 tree var, ctree, tmp;
756 gfc_init_block (&block);
759 for (ref = e->ref; ref; ref = ref->next)
761 if (ref->type == REF_COMPONENT
762 && ref->u.c.component->ts.type == BT_CLASS)
766 if (class_ref == NULL
767 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
768 tmp = e->symtree->n.sym->backend_decl;
771 /* Remove everything after the last class reference, convert the
772 expression and then recover its tailend once more. */
774 ref = class_ref->next;
775 class_ref->next = NULL;
776 gfc_init_se (&tmpse, NULL);
777 gfc_conv_expr (&tmpse, e);
778 class_ref->next = ref;
782 var = gfc_typenode_for_spec (&class_ts);
783 var = gfc_create_var (var, "class");
785 ctree = gfc_class_vptr_get (var);
786 gfc_add_modify (&block, ctree,
787 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
789 ctree = gfc_class_data_get (var);
790 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
791 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
793 /* Pass the address of the class object. */
794 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
798 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
801 tmp = gfc_finish_block (&block);
803 gfc_init_block (&block);
804 tmp2 = gfc_class_data_get (var);
805 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
807 tmp2 = gfc_finish_block (&block);
809 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
811 gfc_add_expr_to_block (&parmse->pre, tmp);
814 gfc_add_block_to_block (&parmse->pre, &block);
818 /* Takes an intrinsic type expression and returns the address of a temporary
819 class object of the 'declared' type. */
821 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
822 gfc_typespec class_ts)
830 /* The intrinsic type needs to be converted to a temporary
832 tmp = gfc_typenode_for_spec (&class_ts);
833 var = gfc_create_var (tmp, "class");
836 ctree = gfc_class_vptr_get (var);
838 vtab = gfc_find_vtab (&e->ts);
840 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
841 gfc_add_modify (&parmse->pre, ctree,
842 fold_convert (TREE_TYPE (ctree), tmp));
844 /* Now set the data field. */
845 ctree = gfc_class_data_get (var);
846 if (parmse->ss && parmse->ss->info->useflags)
848 /* For an array reference in an elemental procedure call we need
849 to retain the ss to provide the scalarized array reference. */
850 gfc_conv_expr_reference (parmse, e);
851 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
852 gfc_add_modify (&parmse->pre, ctree, tmp);
856 ss = gfc_walk_expr (e);
857 if (ss == gfc_ss_terminator)
860 gfc_conv_expr_reference (parmse, e);
861 if (class_ts.u.derived->components->as
862 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
864 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
866 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
867 TREE_TYPE (ctree), tmp);
870 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
871 gfc_add_modify (&parmse->pre, ctree, tmp);
876 parmse->use_offset = 1;
877 gfc_conv_expr_descriptor (parmse, e);
878 if (class_ts.u.derived->components->as->rank != e->rank)
880 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
881 TREE_TYPE (ctree), parmse->expr);
882 gfc_add_modify (&parmse->pre, ctree, tmp);
885 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
889 gcc_assert (class_ts.type == BT_CLASS);
890 if (class_ts.u.derived->components->ts.type == BT_DERIVED
891 && class_ts.u.derived->components->ts.u.derived
892 ->attr.unlimited_polymorphic)
894 ctree = gfc_class_len_get (var);
895 /* When the actual arg is a char array, then set the _len component of the
896 unlimited polymorphic entity to the length of the string. */
897 if (e->ts.type == BT_CHARACTER)
899 /* Start with parmse->string_length because this seems to be set to a
900 correct value more often. */
901 if (parmse->string_length)
902 tmp = parmse->string_length;
903 /* When the string_length is not yet set, then try the backend_decl of
905 else if (e->ts.u.cl->backend_decl)
906 tmp = e->ts.u.cl->backend_decl;
907 /* If both of the above approaches fail, then try to generate an
908 expression from the input, which is only feasible currently, when the
909 expression can be evaluated to a constant one. */
912 /* Try to simplify the expression. */
913 gfc_simplify_expr (e, 0);
914 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
916 /* Amazingly all data is present to compute the length of a
917 constant string, but the expression is not yet there. */
918 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
919 gfc_charlen_int_kind,
921 mpz_set_ui (e->ts.u.cl->length->value.integer,
922 e->value.character.length);
923 gfc_conv_const_charlen (e->ts.u.cl);
924 e->ts.u.cl->resolved = 1;
925 tmp = e->ts.u.cl->backend_decl;
929 gfc_error ("Can't compute the length of the char array at %L.",
935 tmp = integer_zero_node;
937 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
939 else if (class_ts.type == BT_CLASS
940 && class_ts.u.derived->components
941 && class_ts.u.derived->components->ts.u
942 .derived->attr.unlimited_polymorphic)
944 ctree = gfc_class_len_get (var);
945 gfc_add_modify (&parmse->pre, ctree,
946 fold_convert (TREE_TYPE (ctree),
949 /* Pass the address of the class object. */
950 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
954 /* Takes a scalarized class array expression and returns the
955 address of a temporary scalar class object of the 'declared'
957 OOP-TODO: This could be improved by adding code that branched on
958 the dynamic type being the same as the declared type. In this case
959 the original class expression can be passed directly.
960 optional_alloc_ptr is false when the dummy is neither allocatable
961 nor a pointer; that's relevant for the optional handling.
962 Set copyback to true if class container's _data and _vtab pointers
963 might get modified. */
966 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
967 bool elemental, bool copyback, bool optional,
968 bool optional_alloc_ptr)
974 tree cond = NULL_TREE;
975 tree slen = NULL_TREE;
979 bool full_array = false;
981 gfc_init_block (&block);
984 for (ref = e->ref; ref; ref = ref->next)
986 if (ref->type == REF_COMPONENT
987 && ref->u.c.component->ts.type == BT_CLASS)
990 if (ref->next == NULL)
994 if ((ref == NULL || class_ref == ref)
995 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
996 && (!class_ts.u.derived->components->as
997 || class_ts.u.derived->components->as->rank != -1))
1000 /* Test for FULL_ARRAY. */
1001 if (e->rank == 0 && gfc_expr_attr (e).codimension
1002 && gfc_expr_attr (e).dimension)
1005 gfc_is_class_array_ref (e, &full_array);
1007 /* The derived type needs to be converted to a temporary
1009 tmp = gfc_typenode_for_spec (&class_ts);
1010 var = gfc_create_var (tmp, "class");
1013 ctree = gfc_class_data_get (var);
1014 if (class_ts.u.derived->components->as
1015 && e->rank != class_ts.u.derived->components->as->rank)
1019 tree type = get_scalar_to_descriptor_type (parmse->expr,
1021 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1022 gfc_get_dtype (type));
1024 tmp = gfc_class_data_get (parmse->expr);
1025 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1026 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1028 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1031 class_array_data_assign (&block, ctree, parmse->expr, false);
1035 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1036 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1037 TREE_TYPE (ctree), parmse->expr);
1038 gfc_add_modify (&block, ctree, parmse->expr);
1041 /* Return the data component, except in the case of scalarized array
1042 references, where nullification of the cannot occur and so there
1044 if (!elemental && full_array && copyback)
1046 if (class_ts.u.derived->components->as
1047 && e->rank != class_ts.u.derived->components->as->rank)
1050 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1051 gfc_conv_descriptor_data_get (ctree));
1053 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1056 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1060 ctree = gfc_class_vptr_get (var);
1062 /* The vptr is the second field of the actual argument.
1063 First we have to find the corresponding class reference. */
1066 if (gfc_is_class_array_function (e)
1067 && parmse->class_vptr != NULL_TREE)
1068 tmp = parmse->class_vptr;
1069 else if (class_ref == NULL
1070 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1072 tmp = e->symtree->n.sym->backend_decl;
1074 if (TREE_CODE (tmp) == FUNCTION_DECL)
1075 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1077 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1078 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1080 slen = build_zero_cst (size_type_node);
1084 /* Remove everything after the last class reference, convert the
1085 expression and then recover its tailend once more. */
1087 ref = class_ref->next;
1088 class_ref->next = NULL;
1089 gfc_init_se (&tmpse, NULL);
1090 gfc_conv_expr (&tmpse, e);
1091 class_ref->next = ref;
1093 slen = tmpse.string_length;
1096 gcc_assert (tmp != NULL_TREE);
1098 /* Dereference if needs be. */
1099 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1100 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1102 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1103 vptr = gfc_class_vptr_get (tmp);
1107 gfc_add_modify (&block, ctree,
1108 fold_convert (TREE_TYPE (ctree), vptr));
1110 /* Return the vptr component, except in the case of scalarized array
1111 references, where the dynamic type cannot change. */
1112 if (!elemental && full_array && copyback)
1113 gfc_add_modify (&parmse->post, vptr,
1114 fold_convert (TREE_TYPE (vptr), ctree));
1116 /* For unlimited polymorphic objects also set the _len component. */
1117 if (class_ts.type == BT_CLASS
1118 && class_ts.u.derived->components
1119 && class_ts.u.derived->components->ts.u
1120 .derived->attr.unlimited_polymorphic)
1122 ctree = gfc_class_len_get (var);
1123 if (UNLIMITED_POLY (e))
1124 tmp = gfc_class_len_get (tmp);
1125 else if (e->ts.type == BT_CHARACTER)
1127 gcc_assert (slen != NULL_TREE);
1131 tmp = build_zero_cst (size_type_node);
1132 gfc_add_modify (&parmse->pre, ctree,
1133 fold_convert (TREE_TYPE (ctree), tmp));
1135 /* Return the len component, except in the case of scalarized array
1136 references, where the dynamic type cannot change. */
1137 if (!elemental && full_array && copyback
1138 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1139 gfc_add_modify (&parmse->post, tmp,
1140 fold_convert (TREE_TYPE (tmp), ctree));
1147 cond = gfc_conv_expr_present (e->symtree->n.sym);
1148 /* parmse->pre may contain some preparatory instructions for the
1149 temporary array descriptor. Those may only be executed when the
1150 optional argument is set, therefore add parmse->pre's instructions
1151 to block, which is later guarded by an if (optional_arg_given). */
1152 gfc_add_block_to_block (&parmse->pre, &block);
1153 block.head = parmse->pre.head;
1154 parmse->pre.head = NULL_TREE;
1155 tmp = gfc_finish_block (&block);
1157 if (optional_alloc_ptr)
1158 tmp2 = build_empty_stmt (input_location);
1161 gfc_init_block (&block);
1163 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1164 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1165 null_pointer_node));
1166 tmp2 = gfc_finish_block (&block);
1169 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1171 gfc_add_expr_to_block (&parmse->pre, tmp);
1174 gfc_add_block_to_block (&parmse->pre, &block);
1176 /* Pass the address of the class object. */
1177 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1179 if (optional && optional_alloc_ptr)
1180 parmse->expr = build3_loc (input_location, COND_EXPR,
1181 TREE_TYPE (parmse->expr),
1183 fold_convert (TREE_TYPE (parmse->expr),
1184 null_pointer_node));
1188 /* Given a class array declaration and an index, returns the address
1189 of the referenced element. */
1192 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1195 tree data, size, tmp, ctmp, offset, ptr;
1197 data = data_comp != NULL_TREE ? data_comp :
1198 gfc_class_data_get (class_decl);
1199 size = gfc_class_vtab_size_get (class_decl);
1203 tmp = fold_convert (gfc_array_index_type,
1204 gfc_class_len_get (class_decl));
1205 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1206 gfc_array_index_type, size, tmp);
1207 tmp = fold_build2_loc (input_location, GT_EXPR,
1208 logical_type_node, tmp,
1209 build_zero_cst (TREE_TYPE (tmp)));
1210 size = fold_build3_loc (input_location, COND_EXPR,
1211 gfc_array_index_type, tmp, ctmp, size);
1214 offset = fold_build2_loc (input_location, MULT_EXPR,
1215 gfc_array_index_type,
1218 data = gfc_conv_descriptor_data_get (data);
1219 ptr = fold_convert (pvoid_type_node, data);
1220 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1221 return fold_convert (TREE_TYPE (data), ptr);
1225 /* Copies one class expression to another, assuming that if either
1226 'to' or 'from' are arrays they are packed. Should 'from' be
1227 NULL_TREE, the initialization expression for 'to' is used, assuming
1228 that the _vptr is set. */
1231 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1241 vec<tree, va_gc> *args;
1246 bool is_from_desc = false, is_to_class = false;
1249 /* To prevent warnings on uninitialized variables. */
1250 from_len = to_len = NULL_TREE;
1252 if (from != NULL_TREE)
1253 fcn = gfc_class_vtab_copy_get (from);
1255 fcn = gfc_class_vtab_copy_get (to);
1257 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1259 if (from != NULL_TREE)
1261 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1265 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1269 /* Check that from is a class. When the class is part of a coarray,
1270 then from is a common pointer and is to be used as is. */
1271 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1272 ? build_fold_indirect_ref (from) : from;
1274 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1275 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1276 ? gfc_class_data_get (from) : from;
1277 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1281 from_data = gfc_class_vtab_def_init_get (to);
1285 if (from != NULL_TREE && unlimited)
1286 from_len = gfc_class_len_or_zero_get (from);
1288 from_len = build_zero_cst (size_type_node);
1291 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1294 to_data = gfc_class_data_get (to);
1296 to_len = gfc_class_len_get (to);
1299 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1302 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1304 stmtblock_t loopbody;
1308 tree orig_nelems = nelems; /* Needed for bounds check. */
1310 gfc_init_block (&body);
1311 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1312 gfc_array_index_type, nelems,
1313 gfc_index_one_node);
1314 nelems = gfc_evaluate_now (tmp, &body);
1315 index = gfc_create_var (gfc_array_index_type, "S");
1319 from_ref = gfc_get_class_array_ref (index, from, from_data,
1321 vec_safe_push (args, from_ref);
1324 vec_safe_push (args, from_data);
1327 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1330 tmp = gfc_conv_array_data (to);
1331 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1332 to_ref = gfc_build_addr_expr (NULL_TREE,
1333 gfc_build_array_ref (tmp, index, to));
1335 vec_safe_push (args, to_ref);
1337 /* Add bounds check. */
1338 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1341 const char *name = "<<unknown>>";
1345 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1347 from_len = gfc_conv_descriptor_size (from_data, 1);
1348 tmp = fold_build2_loc (input_location, NE_EXPR,
1349 logical_type_node, from_len, orig_nelems);
1350 msg = xasprintf ("Array bound mismatch for dimension %d "
1351 "of array '%s' (%%ld/%%ld)",
1354 gfc_trans_runtime_check (true, false, tmp, &body,
1355 &gfc_current_locus, msg,
1356 fold_convert (long_integer_type_node, orig_nelems),
1357 fold_convert (long_integer_type_node, from_len));
1362 tmp = build_call_vec (fcn_type, fcn, args);
1364 /* Build the body of the loop. */
1365 gfc_init_block (&loopbody);
1366 gfc_add_expr_to_block (&loopbody, tmp);
1368 /* Build the loop and return. */
1369 gfc_init_loopinfo (&loop);
1371 loop.from[0] = gfc_index_zero_node;
1372 loop.loopvar[0] = index;
1373 loop.to[0] = nelems;
1374 gfc_trans_scalarizing_loops (&loop, &loopbody);
1375 gfc_init_block (&ifbody);
1376 gfc_add_block_to_block (&ifbody, &loop.pre);
1377 stdcopy = gfc_finish_block (&ifbody);
1378 /* In initialization mode from_len is a constant zero. */
1379 if (unlimited && !integer_zerop (from_len))
1381 vec_safe_push (args, from_len);
1382 vec_safe_push (args, to_len);
1383 tmp = build_call_vec (fcn_type, fcn, args);
1384 /* Build the body of the loop. */
1385 gfc_init_block (&loopbody);
1386 gfc_add_expr_to_block (&loopbody, tmp);
1388 /* Build the loop and return. */
1389 gfc_init_loopinfo (&loop);
1391 loop.from[0] = gfc_index_zero_node;
1392 loop.loopvar[0] = index;
1393 loop.to[0] = nelems;
1394 gfc_trans_scalarizing_loops (&loop, &loopbody);
1395 gfc_init_block (&ifbody);
1396 gfc_add_block_to_block (&ifbody, &loop.pre);
1397 extcopy = gfc_finish_block (&ifbody);
1399 tmp = fold_build2_loc (input_location, GT_EXPR,
1400 logical_type_node, from_len,
1401 build_zero_cst (TREE_TYPE (from_len)));
1402 tmp = fold_build3_loc (input_location, COND_EXPR,
1403 void_type_node, tmp, extcopy, stdcopy);
1404 gfc_add_expr_to_block (&body, tmp);
1405 tmp = gfc_finish_block (&body);
1409 gfc_add_expr_to_block (&body, stdcopy);
1410 tmp = gfc_finish_block (&body);
1412 gfc_cleanup_loop (&loop);
1416 gcc_assert (!is_from_desc);
1417 vec_safe_push (args, from_data);
1418 vec_safe_push (args, to_data);
1419 stdcopy = build_call_vec (fcn_type, fcn, args);
1421 /* In initialization mode from_len is a constant zero. */
1422 if (unlimited && !integer_zerop (from_len))
1424 vec_safe_push (args, from_len);
1425 vec_safe_push (args, to_len);
1426 extcopy = build_call_vec (fcn_type, fcn, args);
1427 tmp = fold_build2_loc (input_location, GT_EXPR,
1428 logical_type_node, from_len,
1429 build_zero_cst (TREE_TYPE (from_len)));
1430 tmp = fold_build3_loc (input_location, COND_EXPR,
1431 void_type_node, tmp, extcopy, stdcopy);
1437 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1438 if (from == NULL_TREE)
1441 cond = fold_build2_loc (input_location, NE_EXPR,
1443 from_data, null_pointer_node);
1444 tmp = fold_build3_loc (input_location, COND_EXPR,
1445 void_type_node, cond,
1446 tmp, build_empty_stmt (input_location));
1454 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1456 gfc_actual_arglist *actual;
1461 actual = gfc_get_actual_arglist ();
1462 actual->expr = gfc_copy_expr (rhs);
1463 actual->next = gfc_get_actual_arglist ();
1464 actual->next->expr = gfc_copy_expr (lhs);
1465 ppc = gfc_copy_expr (obj);
1466 gfc_add_vptr_component (ppc);
1467 gfc_add_component_ref (ppc, "_copy");
1468 ppc_code = gfc_get_code (EXEC_CALL);
1469 ppc_code->resolved_sym = ppc->symtree->n.sym;
1470 /* Although '_copy' is set to be elemental in class.c, it is
1471 not staying that way. Find out why, sometime.... */
1472 ppc_code->resolved_sym->attr.elemental = 1;
1473 ppc_code->ext.actual = actual;
1474 ppc_code->expr1 = ppc;
1475 /* Since '_copy' is elemental, the scalarizer will take care
1476 of arrays in gfc_trans_call. */
1477 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1478 gfc_free_statements (ppc_code);
1480 if (UNLIMITED_POLY(obj))
1482 /* Check if rhs is non-NULL. */
1484 gfc_init_se (&src, NULL);
1485 gfc_conv_expr (&src, rhs);
1486 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1487 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1488 src.expr, fold_convert (TREE_TYPE (src.expr),
1489 null_pointer_node));
1490 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1491 build_empty_stmt (input_location));
1497 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1498 A MEMCPY is needed to copy the full data from the default initializer
1499 of the dynamic type. */
1502 gfc_trans_class_init_assign (gfc_code *code)
1506 gfc_se dst,src,memsz;
1507 gfc_expr *lhs, *rhs, *sz;
1509 gfc_start_block (&block);
1511 lhs = gfc_copy_expr (code->expr1);
1513 rhs = gfc_copy_expr (code->expr1);
1514 gfc_add_vptr_component (rhs);
1516 /* Make sure that the component backend_decls have been built, which
1517 will not have happened if the derived types concerned have not
1519 gfc_get_derived_type (rhs->ts.u.derived);
1520 gfc_add_def_init_component (rhs);
1521 /* The _def_init is always scalar. */
1524 if (code->expr1->ts.type == BT_CLASS
1525 && CLASS_DATA (code->expr1)->attr.dimension)
1527 gfc_array_spec *tmparr = gfc_get_array_spec ();
1528 *tmparr = *CLASS_DATA (code->expr1)->as;
1529 /* Adding the array ref to the class expression results in correct
1530 indexing to the dynamic type. */
1531 gfc_add_full_array_ref (lhs, tmparr);
1532 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1536 /* Scalar initialization needs the _data component. */
1537 gfc_add_data_component (lhs);
1538 sz = gfc_copy_expr (code->expr1);
1539 gfc_add_vptr_component (sz);
1540 gfc_add_size_component (sz);
1542 gfc_init_se (&dst, NULL);
1543 gfc_init_se (&src, NULL);
1544 gfc_init_se (&memsz, NULL);
1545 gfc_conv_expr (&dst, lhs);
1546 gfc_conv_expr (&src, rhs);
1547 gfc_conv_expr (&memsz, sz);
1548 gfc_add_block_to_block (&block, &src.pre);
1549 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1551 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1553 if (UNLIMITED_POLY(code->expr1))
1555 /* Check if _def_init is non-NULL. */
1556 tree cond = fold_build2_loc (input_location, NE_EXPR,
1557 logical_type_node, src.expr,
1558 fold_convert (TREE_TYPE (src.expr),
1559 null_pointer_node));
1560 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1561 tmp, build_empty_stmt (input_location));
1565 if (code->expr1->symtree->n.sym->attr.optional
1566 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1568 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1569 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1571 build_empty_stmt (input_location));
1574 gfc_add_expr_to_block (&block, tmp);
1576 return gfc_finish_block (&block);
1580 /* End of prototype trans-class.c */
1584 realloc_lhs_warning (bt type, bool array, locus *where)
1586 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1587 gfc_warning (OPT_Wrealloc_lhs,
1588 "Code for reallocating the allocatable array at %L will "
1590 else if (warn_realloc_lhs_all)
1591 gfc_warning (OPT_Wrealloc_lhs_all,
1592 "Code for reallocating the allocatable variable at %L "
1593 "will be added", where);
1597 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1600 /* Copy the scalarization loop variables. */
1603 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1606 dest->loop = src->loop;
1610 /* Initialize a simple expression holder.
1612 Care must be taken when multiple se are created with the same parent.
1613 The child se must be kept in sync. The easiest way is to delay creation
1614 of a child se until after after the previous se has been translated. */
1617 gfc_init_se (gfc_se * se, gfc_se * parent)
1619 memset (se, 0, sizeof (gfc_se));
1620 gfc_init_block (&se->pre);
1621 gfc_init_block (&se->post);
1623 se->parent = parent;
1626 gfc_copy_se_loopvars (se, parent);
1630 /* Advances to the next SS in the chain. Use this rather than setting
1631 se->ss = se->ss->next because all the parents needs to be kept in sync.
1635 gfc_advance_se_ss_chain (gfc_se * se)
1640 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1643 /* Walk down the parent chain. */
1646 /* Simple consistency check. */
1647 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1648 || p->parent->ss->nested_ss == p->ss);
1650 /* If we were in a nested loop, the next scalarized expression can be
1651 on the parent ss' next pointer. Thus we should not take the next
1652 pointer blindly, but rather go up one nest level as long as next
1653 is the end of chain. */
1655 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1665 /* Ensures the result of the expression as either a temporary variable
1666 or a constant so that it can be used repeatedly. */
1669 gfc_make_safe_expr (gfc_se * se)
1673 if (CONSTANT_CLASS_P (se->expr))
1676 /* We need a temporary for this result. */
1677 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1678 gfc_add_modify (&se->pre, var, se->expr);
1683 /* Return an expression which determines if a dummy parameter is present.
1684 Also used for arguments to procedures with multiple entry points. */
1687 gfc_conv_expr_present (gfc_symbol * sym)
1691 gcc_assert (sym->attr.dummy);
1692 decl = gfc_get_symbol_decl (sym);
1694 /* Intrinsic scalars with VALUE attribute which are passed by value
1695 use a hidden argument to denote the present status. */
1696 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1697 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1698 && !sym->attr.dimension)
1700 char name[GFC_MAX_SYMBOL_LEN + 2];
1703 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1705 strcpy (&name[1], sym->name);
1706 tree_name = get_identifier (name);
1708 /* Walk function argument list to find hidden arg. */
1709 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1710 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1711 if (DECL_NAME (cond) == tree_name)
1718 if (TREE_CODE (decl) != PARM_DECL)
1720 /* Array parameters use a temporary descriptor, we want the real
1722 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1723 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1724 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1727 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1728 fold_convert (TREE_TYPE (decl), null_pointer_node));
1730 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1731 as actual argument to denote absent dummies. For array descriptors,
1732 we thus also need to check the array descriptor. For BT_CLASS, it
1733 can also occur for scalars and F2003 due to type->class wrapping and
1734 class->class wrapping. Note further that BT_CLASS always uses an
1735 array descriptor for arrays, also for explicit-shape/assumed-size. */
1737 if (!sym->attr.allocatable
1738 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1739 || (sym->ts.type == BT_CLASS
1740 && !CLASS_DATA (sym)->attr.allocatable
1741 && !CLASS_DATA (sym)->attr.class_pointer))
1742 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1743 || sym->ts.type == BT_CLASS))
1747 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1748 || sym->as->type == AS_ASSUMED_RANK
1749 || sym->attr.codimension))
1750 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1752 tmp = build_fold_indirect_ref_loc (input_location, decl);
1753 if (sym->ts.type == BT_CLASS)
1754 tmp = gfc_class_data_get (tmp);
1755 tmp = gfc_conv_array_data (tmp);
1757 else if (sym->ts.type == BT_CLASS)
1758 tmp = gfc_class_data_get (decl);
1762 if (tmp != NULL_TREE)
1764 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1765 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1766 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1767 logical_type_node, cond, tmp);
1775 /* Converts a missing, dummy argument into a null or zero. */
1778 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1783 present = gfc_conv_expr_present (arg->symtree->n.sym);
1787 /* Create a temporary and convert it to the correct type. */
1788 tmp = gfc_get_int_type (kind);
1789 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1792 /* Test for a NULL value. */
1793 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1794 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1795 tmp = gfc_evaluate_now (tmp, &se->pre);
1796 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1800 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1802 build_zero_cst (TREE_TYPE (se->expr)));
1803 tmp = gfc_evaluate_now (tmp, &se->pre);
1807 if (ts.type == BT_CHARACTER)
1809 tmp = build_int_cst (gfc_charlen_type_node, 0);
1810 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1811 present, se->string_length, tmp);
1812 tmp = gfc_evaluate_now (tmp, &se->pre);
1813 se->string_length = tmp;
1819 /* Get the character length of an expression, looking through gfc_refs
1823 gfc_get_expr_charlen (gfc_expr *e)
1828 gcc_assert (e->expr_type == EXPR_VARIABLE
1829 && e->ts.type == BT_CHARACTER);
1831 length = NULL; /* To silence compiler warning. */
1833 if (is_subref_array (e) && e->ts.u.cl->length)
1836 gfc_init_se (&tmpse, NULL);
1837 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1838 e->ts.u.cl->backend_decl = tmpse.expr;
1842 /* First candidate: if the variable is of type CHARACTER, the
1843 expression's length could be the length of the character
1845 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1846 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1848 /* Look through the reference chain for component references. */
1849 for (r = e->ref; r; r = r->next)
1854 if (r->u.c.component->ts.type == BT_CHARACTER)
1855 length = r->u.c.component->ts.u.cl->backend_decl;
1863 /* We should never got substring references here. These will be
1864 broken down by the scalarizer. */
1870 gcc_assert (length != NULL);
1875 /* Return for an expression the backend decl of the coarray. */
1878 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1884 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1886 /* Not-implemented diagnostic. */
1887 if (expr->symtree->n.sym->ts.type == BT_CLASS
1888 && UNLIMITED_POLY (expr->symtree->n.sym)
1889 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1890 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1891 "%L is not supported", &expr->where);
1893 for (ref = expr->ref; ref; ref = ref->next)
1894 if (ref->type == REF_COMPONENT)
1896 if (ref->u.c.component->ts.type == BT_CLASS
1897 && UNLIMITED_POLY (ref->u.c.component)
1898 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1899 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1900 "component at %L is not supported", &expr->where);
1903 /* Make sure the backend_decl is present before accessing it. */
1904 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1905 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1906 : expr->symtree->n.sym->backend_decl;
1908 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1910 if (expr->ref && expr->ref->type == REF_ARRAY)
1912 caf_decl = gfc_class_data_get (caf_decl);
1913 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1916 for (ref = expr->ref; ref; ref = ref->next)
1918 if (ref->type == REF_COMPONENT
1919 && strcmp (ref->u.c.component->name, "_data") != 0)
1921 caf_decl = gfc_class_data_get (caf_decl);
1922 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1926 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1930 if (expr->symtree->n.sym->attr.codimension)
1933 /* The following code assumes that the coarray is a component reachable via
1934 only scalar components/variables; the Fortran standard guarantees this. */
1936 for (ref = expr->ref; ref; ref = ref->next)
1937 if (ref->type == REF_COMPONENT)
1939 gfc_component *comp = ref->u.c.component;
1941 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1942 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1943 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1944 TREE_TYPE (comp->backend_decl), caf_decl,
1945 comp->backend_decl, NULL_TREE);
1946 if (comp->ts.type == BT_CLASS)
1948 caf_decl = gfc_class_data_get (caf_decl);
1949 if (CLASS_DATA (comp)->attr.codimension)
1955 if (comp->attr.codimension)
1961 gcc_assert (found && caf_decl);
1966 /* Obtain the Coarray token - and optionally also the offset. */
1969 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1970 tree se_expr, gfc_expr *expr)
1974 /* Coarray token. */
1975 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1977 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1978 == GFC_ARRAY_ALLOCATABLE
1979 || expr->symtree->n.sym->attr.select_type_temporary);
1980 *token = gfc_conv_descriptor_token (caf_decl);
1982 else if (DECL_LANG_SPECIFIC (caf_decl)
1983 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1984 *token = GFC_DECL_TOKEN (caf_decl);
1987 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1988 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1989 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1995 /* Offset between the coarray base address and the address wanted. */
1996 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1997 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1998 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1999 *offset = build_int_cst (gfc_array_index_type, 0);
2000 else if (DECL_LANG_SPECIFIC (caf_decl)
2001 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2002 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2003 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2004 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2006 *offset = build_int_cst (gfc_array_index_type, 0);
2008 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2009 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2011 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2012 tmp = gfc_conv_descriptor_data_get (tmp);
2014 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2015 tmp = gfc_conv_descriptor_data_get (se_expr);
2018 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2022 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2023 *offset, fold_convert (gfc_array_index_type, tmp));
2025 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2026 && expr->symtree->n.sym->attr.codimension
2027 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2029 gfc_expr *base_expr = gfc_copy_expr (expr);
2030 gfc_ref *ref = base_expr->ref;
2033 // Iterate through the refs until the last one.
2037 if (ref->type == REF_ARRAY
2038 && ref->u.ar.type != AR_FULL)
2040 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2042 for (i = 0; i < ranksum; ++i)
2044 ref->u.ar.start[i] = NULL;
2045 ref->u.ar.end[i] = NULL;
2047 ref->u.ar.type = AR_FULL;
2049 gfc_init_se (&base_se, NULL);
2050 if (gfc_caf_attr (base_expr).dimension)
2052 gfc_conv_expr_descriptor (&base_se, base_expr);
2053 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2057 gfc_conv_expr (&base_se, base_expr);
2061 gfc_free_expr (base_expr);
2062 gfc_add_block_to_block (&se->pre, &base_se.pre);
2063 gfc_add_block_to_block (&se->post, &base_se.post);
2065 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2066 tmp = gfc_conv_descriptor_data_get (caf_decl);
2069 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2073 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2074 fold_convert (gfc_array_index_type, *offset),
2075 fold_convert (gfc_array_index_type, tmp));
2079 /* Convert the coindex of a coarray into an image index; the result is
2080 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2081 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2084 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2087 tree lbound, ubound, extent, tmp, img_idx;
2091 for (ref = e->ref; ref; ref = ref->next)
2092 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2094 gcc_assert (ref != NULL);
2096 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2098 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2102 img_idx = build_zero_cst (gfc_array_index_type);
2103 extent = build_one_cst (gfc_array_index_type);
2104 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2105 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2107 gfc_init_se (&se, NULL);
2108 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2109 gfc_add_block_to_block (block, &se.pre);
2110 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2111 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2112 TREE_TYPE (lbound), se.expr, lbound);
2113 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2115 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2116 TREE_TYPE (tmp), img_idx, tmp);
2117 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2119 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2120 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2121 extent = fold_build2_loc (input_location, MULT_EXPR,
2122 TREE_TYPE (tmp), extent, tmp);
2126 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2128 gfc_init_se (&se, NULL);
2129 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2130 gfc_add_block_to_block (block, &se.pre);
2131 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2132 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2133 TREE_TYPE (lbound), se.expr, lbound);
2134 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2136 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2138 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2140 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2141 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2142 TREE_TYPE (ubound), ubound, lbound);
2143 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2144 tmp, build_one_cst (TREE_TYPE (tmp)));
2145 extent = fold_build2_loc (input_location, MULT_EXPR,
2146 TREE_TYPE (tmp), extent, tmp);
2149 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2150 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2151 return fold_convert (integer_type_node, img_idx);
2155 /* For each character array constructor subexpression without a ts.u.cl->length,
2156 replace it by its first element (if there aren't any elements, the length
2157 should already be set to zero). */
2160 flatten_array_ctors_without_strlen (gfc_expr* e)
2162 gfc_actual_arglist* arg;
2168 switch (e->expr_type)
2172 flatten_array_ctors_without_strlen (e->value.op.op1);
2173 flatten_array_ctors_without_strlen (e->value.op.op2);
2177 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2181 for (arg = e->value.function.actual; arg; arg = arg->next)
2182 flatten_array_ctors_without_strlen (arg->expr);
2187 /* We've found what we're looking for. */
2188 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2193 gcc_assert (e->value.constructor);
2195 c = gfc_constructor_first (e->value.constructor);
2199 flatten_array_ctors_without_strlen (new_expr);
2200 gfc_replace_expr (e, new_expr);
2204 /* Otherwise, fall through to handle constructor elements. */
2206 case EXPR_STRUCTURE:
2207 for (c = gfc_constructor_first (e->value.constructor);
2208 c; c = gfc_constructor_next (c))
2209 flatten_array_ctors_without_strlen (c->expr);
2219 /* Generate code to initialize a string length variable. Returns the
2220 value. For array constructors, cl->length might be NULL and in this case,
2221 the first element of the constructor is needed. expr is the original
2222 expression so we can access it but can be NULL if this is not needed. */
2225 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2229 gfc_init_se (&se, NULL);
2231 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2234 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2235 "flatten" array constructors by taking their first element; all elements
2236 should be the same length or a cl->length should be present. */
2239 gfc_expr* expr_flat;
2242 expr_flat = gfc_copy_expr (expr);
2243 flatten_array_ctors_without_strlen (expr_flat);
2244 gfc_resolve_expr (expr_flat);
2246 gfc_conv_expr (&se, expr_flat);
2247 gfc_add_block_to_block (pblock, &se.pre);
2248 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2250 gfc_free_expr (expr_flat);
2254 /* Convert cl->length. */
2256 gcc_assert (cl->length);
2258 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2259 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2260 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2261 gfc_add_block_to_block (pblock, &se.pre);
2263 if (cl->backend_decl)
2264 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2266 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2271 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2272 const char *name, locus *where)
2282 type = gfc_get_character_type (kind, ref->u.ss.length);
2283 type = build_pointer_type (type);
2285 gfc_init_se (&start, se);
2286 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2287 gfc_add_block_to_block (&se->pre, &start.pre);
2289 if (integer_onep (start.expr))
2290 gfc_conv_string_parameter (se);
2295 /* Avoid multiple evaluation of substring start. */
2296 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2297 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2299 /* Change the start of the string. */
2300 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2303 tmp = build_fold_indirect_ref_loc (input_location,
2305 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2306 se->expr = gfc_build_addr_expr (type, tmp);
2309 /* Length = end + 1 - start. */
2310 gfc_init_se (&end, se);
2311 if (ref->u.ss.end == NULL)
2312 end.expr = se->string_length;
2315 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2316 gfc_add_block_to_block (&se->pre, &end.pre);
2320 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2321 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2323 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2325 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2326 logical_type_node, start.expr,
2329 /* Check lower bound. */
2330 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2332 build_one_cst (TREE_TYPE (start.expr)));
2333 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2334 logical_type_node, nonempty, fault);
2336 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2337 "is less than one", name);
2339 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2340 "is less than one");
2341 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2342 fold_convert (long_integer_type_node,
2346 /* Check upper bound. */
2347 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2348 end.expr, se->string_length);
2349 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2350 logical_type_node, nonempty, fault);
2352 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2353 "exceeds string length (%%ld)", name);
2355 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2356 "exceeds string length (%%ld)");
2357 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2358 fold_convert (long_integer_type_node, end.expr),
2359 fold_convert (long_integer_type_node,
2360 se->string_length));
2364 /* Try to calculate the length from the start and end expressions. */
2366 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2368 HOST_WIDE_INT i_len;
2370 i_len = gfc_mpz_get_hwi (length) + 1;
2374 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2375 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2379 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2380 fold_convert (gfc_charlen_type_node, end.expr),
2381 fold_convert (gfc_charlen_type_node, start.expr));
2382 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2383 build_int_cst (gfc_charlen_type_node, 1), tmp);
2384 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2385 tmp, build_int_cst (gfc_charlen_type_node, 0));
2388 se->string_length = tmp;
2392 /* Convert a derived type component reference. */
2395 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2403 c = ref->u.c.component;
2405 if (c->backend_decl == NULL_TREE
2406 && ref->u.c.sym != NULL)
2407 gfc_get_derived_type (ref->u.c.sym);
2409 field = c->backend_decl;
2410 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2412 context = DECL_FIELD_CONTEXT (field);
2414 /* Components can correspond to fields of different containing
2415 types, as components are created without context, whereas
2416 a concrete use of a component has the type of decl as context.
2417 So, if the type doesn't match, we search the corresponding
2418 FIELD_DECL in the parent type. To not waste too much time
2419 we cache this result in norestrict_decl.
2420 On the other hand, if the context is a UNION or a MAP (a
2421 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2423 if (context != TREE_TYPE (decl)
2424 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2425 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2427 tree f2 = c->norestrict_decl;
2428 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2429 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2430 if (TREE_CODE (f2) == FIELD_DECL
2431 && DECL_NAME (f2) == DECL_NAME (field))
2434 c->norestrict_decl = f2;
2438 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2439 && strcmp ("_data", c->name) == 0)
2441 /* Found a ref to the _data component. Store the associated ref to
2442 the vptr in se->class_vptr. */
2443 se->class_vptr = gfc_class_vptr_get (decl);
2446 se->class_vptr = NULL_TREE;
2448 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2449 decl, field, NULL_TREE);
2453 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2454 strlen () conditional below. */
2455 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2456 && !(c->attr.allocatable && c->ts.deferred)
2457 && !c->attr.pdt_string)
2459 tmp = c->ts.u.cl->backend_decl;
2460 /* Components must always be constant length. */
2461 gcc_assert (tmp && INTEGER_CST_P (tmp));
2462 se->string_length = tmp;
2465 if (gfc_deferred_strlen (c, &field))
2467 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2469 decl, field, NULL_TREE);
2470 se->string_length = tmp;
2473 if (((c->attr.pointer || c->attr.allocatable)
2474 && (!c->attr.dimension && !c->attr.codimension)
2475 && c->ts.type != BT_CHARACTER)
2476 || c->attr.proc_pointer)
2477 se->expr = build_fold_indirect_ref_loc (input_location,
2482 /* This function deals with component references to components of the
2483 parent type for derived type extensions. */
2485 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2493 c = ref->u.c.component;
2495 /* Return if the component is in the parent type. */
2496 for (cmp = dt->components; cmp; cmp = cmp->next)
2497 if (strcmp (c->name, cmp->name) == 0)
2500 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2501 parent.type = REF_COMPONENT;
2503 parent.u.c.sym = dt;
2504 parent.u.c.component = dt->components;
2506 if (dt->backend_decl == NULL)
2507 gfc_get_derived_type (dt);
2509 /* Build the reference and call self. */
2510 gfc_conv_component_ref (se, &parent);
2511 parent.u.c.sym = dt->components->ts.u.derived;
2512 parent.u.c.component = c;
2513 conv_parent_component_references (se, &parent);
2518 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2520 tree res = se->expr;
2525 res = fold_build1_loc (input_location, REALPART_EXPR,
2526 TREE_TYPE (TREE_TYPE (res)), res);
2530 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2531 TREE_TYPE (TREE_TYPE (res)), res);
2535 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2540 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2550 /* Return the contents of a variable. Also handles reference/pointer
2551 variables (all Fortran pointer references are implicit). */
2554 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2559 tree parent_decl = NULL_TREE;
2562 bool alternate_entry;
2565 bool first_time = true;
2567 sym = expr->symtree->n.sym;
2568 is_classarray = IS_CLASS_ARRAY (sym);
2572 gfc_ss_info *ss_info = ss->info;
2574 /* Check that something hasn't gone horribly wrong. */
2575 gcc_assert (ss != gfc_ss_terminator);
2576 gcc_assert (ss_info->expr == expr);
2578 /* A scalarized term. We already know the descriptor. */
2579 se->expr = ss_info->data.array.descriptor;
2580 se->string_length = ss_info->string_length;
2581 ref = ss_info->data.array.ref;
2583 gcc_assert (ref->type == REF_ARRAY
2584 && ref->u.ar.type != AR_ELEMENT);
2586 gfc_conv_tmp_array_ref (se);
2590 tree se_expr = NULL_TREE;
2592 se->expr = gfc_get_symbol_decl (sym);
2594 /* Deal with references to a parent results or entries by storing
2595 the current_function_decl and moving to the parent_decl. */
2596 return_value = sym->attr.function && sym->result == sym;
2597 alternate_entry = sym->attr.function && sym->attr.entry
2598 && sym->result == sym;
2599 entry_master = sym->attr.result
2600 && sym->ns->proc_name->attr.entry_master
2601 && !gfc_return_by_reference (sym->ns->proc_name);
2602 if (current_function_decl)
2603 parent_decl = DECL_CONTEXT (current_function_decl);
2605 if ((se->expr == parent_decl && return_value)
2606 || (sym->ns && sym->ns->proc_name
2608 && sym->ns->proc_name->backend_decl == parent_decl
2609 && (alternate_entry || entry_master)))
2614 /* Special case for assigning the return value of a function.
2615 Self recursive functions must have an explicit return value. */
2616 if (return_value && (se->expr == current_function_decl || parent_flag))
2617 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2619 /* Similarly for alternate entry points. */
2620 else if (alternate_entry
2621 && (sym->ns->proc_name->backend_decl == current_function_decl
2624 gfc_entry_list *el = NULL;
2626 for (el = sym->ns->entries; el; el = el->next)
2629 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2634 else if (entry_master
2635 && (sym->ns->proc_name->backend_decl == current_function_decl
2637 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2642 /* Procedure actual arguments. Look out for temporary variables
2643 with the same attributes as function values. */
2644 else if (!sym->attr.temporary
2645 && sym->attr.flavor == FL_PROCEDURE
2646 && se->expr != current_function_decl)
2648 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2650 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2651 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2657 /* Dereference the expression, where needed. Since characters
2658 are entirely different from other types, they are treated
2660 if (sym->ts.type == BT_CHARACTER)
2662 /* Dereference character pointer dummy arguments
2664 if ((sym->attr.pointer || sym->attr.allocatable)
2666 || sym->attr.function
2667 || sym->attr.result))
2668 se->expr = build_fold_indirect_ref_loc (input_location,
2672 else if (!sym->attr.value)
2674 /* Dereference temporaries for class array dummy arguments. */
2675 if (sym->attr.dummy && is_classarray
2676 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2678 if (!se->descriptor_only)
2679 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2681 se->expr = build_fold_indirect_ref_loc (input_location,
2685 /* Dereference non-character scalar dummy arguments. */
2686 if (sym->attr.dummy && !sym->attr.dimension
2687 && !(sym->attr.codimension && sym->attr.allocatable)
2688 && (sym->ts.type != BT_CLASS
2689 || (!CLASS_DATA (sym)->attr.dimension
2690 && !(CLASS_DATA (sym)->attr.codimension
2691 && CLASS_DATA (sym)->attr.allocatable))))
2692 se->expr = build_fold_indirect_ref_loc (input_location,
2695 /* Dereference scalar hidden result. */
2696 if (flag_f2c && sym->ts.type == BT_COMPLEX
2697 && (sym->attr.function || sym->attr.result)
2698 && !sym->attr.dimension && !sym->attr.pointer
2699 && !sym->attr.always_explicit)
2700 se->expr = build_fold_indirect_ref_loc (input_location,
2703 /* Dereference non-character, non-class pointer variables.
2704 These must be dummies, results, or scalars. */
2706 && (sym->attr.pointer || sym->attr.allocatable
2707 || gfc_is_associate_pointer (sym)
2708 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2710 || sym->attr.function
2712 || (!sym->attr.dimension
2713 && (!sym->attr.codimension || !sym->attr.allocatable))))
2714 se->expr = build_fold_indirect_ref_loc (input_location,
2716 /* Now treat the class array pointer variables accordingly. */
2717 else if (sym->ts.type == BT_CLASS
2719 && (CLASS_DATA (sym)->attr.dimension
2720 || CLASS_DATA (sym)->attr.codimension)
2721 && ((CLASS_DATA (sym)->as
2722 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2723 || CLASS_DATA (sym)->attr.allocatable
2724 || CLASS_DATA (sym)->attr.class_pointer))
2725 se->expr = build_fold_indirect_ref_loc (input_location,
2727 /* And the case where a non-dummy, non-result, non-function,
2728 non-allotable and non-pointer classarray is present. This case was
2729 previously covered by the first if, but with introducing the
2730 condition !is_classarray there, that case has to be covered
2732 else if (sym->ts.type == BT_CLASS
2734 && !sym->attr.function
2735 && !sym->attr.result
2736 && (CLASS_DATA (sym)->attr.dimension
2737 || CLASS_DATA (sym)->attr.codimension)
2739 || !CLASS_DATA (sym)->attr.allocatable)
2740 && !CLASS_DATA (sym)->attr.class_pointer)
2741 se->expr = build_fold_indirect_ref_loc (input_location,
2748 /* For character variables, also get the length. */
2749 if (sym->ts.type == BT_CHARACTER)
2751 /* If the character length of an entry isn't set, get the length from
2752 the master function instead. */
2753 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2754 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2756 se->string_length = sym->ts.u.cl->backend_decl;
2757 gcc_assert (se->string_length);
2760 gfc_typespec *ts = &sym->ts;
2766 /* Return the descriptor if that's what we want and this is an array
2767 section reference. */
2768 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2770 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2771 /* Return the descriptor for array pointers and allocations. */
2772 if (se->want_pointer
2773 && ref->next == NULL && (se->descriptor_only))
2776 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2777 /* Return a pointer to an element. */
2781 ts = &ref->u.c.component->ts;
2782 if (first_time && is_classarray && sym->attr.dummy
2783 && se->descriptor_only
2784 && !CLASS_DATA (sym)->attr.allocatable
2785 && !CLASS_DATA (sym)->attr.class_pointer
2786 && CLASS_DATA (sym)->as
2787 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2788 && strcmp ("_data", ref->u.c.component->name) == 0)
2789 /* Skip the first ref of a _data component, because for class
2790 arrays that one is already done by introducing a temporary
2791 array descriptor. */
2794 if (ref->u.c.sym->attr.extension)
2795 conv_parent_component_references (se, ref);
2797 gfc_conv_component_ref (se, ref);
2798 if (!ref->next && ref->u.c.sym->attr.codimension
2799 && se->want_pointer && se->descriptor_only)
2805 gfc_conv_substring (se, ref, expr->ts.kind,
2806 expr->symtree->name, &expr->where);
2810 conv_inquiry (se, ref, expr, ts);
2820 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2822 if (se->want_pointer)
2824 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2825 gfc_conv_string_parameter (se);
2827 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2832 /* Unary ops are easy... Or they would be if ! was a valid op. */
2835 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2840 gcc_assert (expr->ts.type != BT_CHARACTER);
2841 /* Initialize the operand. */
2842 gfc_init_se (&operand, se);
2843 gfc_conv_expr_val (&operand, expr->value.op.op1);
2844 gfc_add_block_to_block (&se->pre, &operand.pre);
2846 type = gfc_typenode_for_spec (&expr->ts);
2848 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2849 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2850 All other unary operators have an equivalent GIMPLE unary operator. */
2851 if (code == TRUTH_NOT_EXPR)
2852 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2853 build_int_cst (type, 0));
2855 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2859 /* Expand power operator to optimal multiplications when a value is raised
2860 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2861 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2862 Programming", 3rd Edition, 1998. */
2864 /* This code is mostly duplicated from expand_powi in the backend.
2865 We establish the "optimal power tree" lookup table with the defined size.
2866 The items in the table are the exponents used to calculate the index
2867 exponents. Any integer n less than the value can get an "addition chain",
2868 with the first node being one. */
2869 #define POWI_TABLE_SIZE 256
2871 /* The table is from builtins.c. */
2872 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2874 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2875 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2876 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2877 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2878 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2879 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2880 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2881 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2882 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2883 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2884 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2885 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2886 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2887 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2888 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2889 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2890 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2891 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2892 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2893 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2894 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2895 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2896 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2897 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2898 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2899 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2900 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2901 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2902 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2903 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2904 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2905 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2908 /* If n is larger than lookup table's max index, we use the "window
2910 #define POWI_WINDOW_SIZE 3
2912 /* Recursive function to expand the power operator. The temporary
2913 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2915 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2922 if (n < POWI_TABLE_SIZE)
2927 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2928 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2932 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2933 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2934 op1 = gfc_conv_powi (se, digit, tmpvar);
2938 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2942 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2943 tmp = gfc_evaluate_now (tmp, &se->pre);
2945 if (n < POWI_TABLE_SIZE)
2952 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2953 return 1. Else return 0 and a call to runtime library functions
2954 will have to be built. */
2956 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2961 tree vartmp[POWI_TABLE_SIZE];
2963 unsigned HOST_WIDE_INT n;
2965 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2967 /* If exponent is too large, we won't expand it anyway, so don't bother
2968 with large integer values. */
2969 if (!wi::fits_shwi_p (wrhs))
2972 m = wrhs.to_shwi ();
2973 /* Use the wide_int's routine to reliably get the absolute value on all
2974 platforms. Then convert it to a HOST_WIDE_INT like above. */
2975 n = wi::abs (wrhs).to_shwi ();
2977 type = TREE_TYPE (lhs);
2978 sgn = tree_int_cst_sgn (rhs);
2980 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2981 || optimize_size) && (m > 2 || m < -1))
2987 se->expr = gfc_build_const (type, integer_one_node);
2991 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2992 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2994 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2995 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2996 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2997 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3000 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3003 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3004 logical_type_node, tmp, cond);
3005 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3006 tmp, build_int_cst (type, 1),
3007 build_int_cst (type, 0));
3011 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3012 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3013 build_int_cst (type, -1),
3014 build_int_cst (type, 0));
3015 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3016 cond, build_int_cst (type, 1), tmp);
3020 memset (vartmp, 0, sizeof (vartmp));
3024 tmp = gfc_build_const (type, integer_one_node);
3025 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3029 se->expr = gfc_conv_powi (se, n, vartmp);
3035 /* Power op (**). Constant integer exponent has special handling. */
3038 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3040 tree gfc_int4_type_node;
3043 int res_ikind_1, res_ikind_2;
3048 gfc_init_se (&lse, se);
3049 gfc_conv_expr_val (&lse, expr->value.op.op1);
3050 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3051 gfc_add_block_to_block (&se->pre, &lse.pre);
3053 gfc_init_se (&rse, se);
3054 gfc_conv_expr_val (&rse, expr->value.op.op2);
3055 gfc_add_block_to_block (&se->pre, &rse.pre);
3057 if (expr->value.op.op2->ts.type == BT_INTEGER
3058 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3059 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3062 if (INTEGER_CST_P (lse.expr)
3063 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3065 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3067 int kind, ikind, bit_size;
3069 v = wlhs.to_shwi ();
3072 kind = expr->value.op.op1->ts.kind;
3073 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3074 bit_size = gfc_integer_kinds[ikind].bit_size;
3078 /* 1**something is always 1. */
3079 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3084 /* (-1)**n is 1 - ((n & 1) << 1) */
3088 type = TREE_TYPE (lse.expr);
3089 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3090 rse.expr, build_int_cst (type, 1));
3091 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3092 tmp, build_int_cst (type, 1));
3093 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3094 build_int_cst (type, 1), tmp);
3098 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3100 /* Here v is +/- 2**e. The further simplification uses
3101 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3102 1<<(4*n), etc., but we have to make sure to return zero
3103 if the number of bits is too large. */
3113 type = TREE_TYPE (lse.expr);
3118 shift = fold_build2_loc (input_location, PLUS_EXPR,
3119 TREE_TYPE (rse.expr),
3120 rse.expr, rse.expr);
3123 /* use popcount for fast log2(w) */
3124 int e = wi::popcount (w-1);
3125 shift = fold_build2_loc (input_location, MULT_EXPR,
3126 TREE_TYPE (rse.expr),
3127 build_int_cst (TREE_TYPE (rse.expr), e),
3131 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3132 build_int_cst (type, 1), shift);
3133 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3134 rse.expr, build_int_cst (type, 0));
3135 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3136 build_int_cst (type, 0));
3137 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3138 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3139 rse.expr, num_bits);
3140 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3141 build_int_cst (type, 0), cond);
3148 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3150 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3151 rse.expr, build_int_cst (type, 1));
3152 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3153 tmp2, build_int_cst (type, 1));
3154 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3155 build_int_cst (type, 1), tmp2);
3156 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3163 gfc_int4_type_node = gfc_get_int_type (4);
3165 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3166 library routine. But in the end, we have to convert the result back
3167 if this case applies -- with res_ikind_K, we keep track whether operand K
3168 falls into this case. */
3172 kind = expr->value.op.op1->ts.kind;
3173 switch (expr->value.op.op2->ts.type)
3176 ikind = expr->value.op.op2->ts.kind;
3181 rse.expr = convert (gfc_int4_type_node, rse.expr);
3182 res_ikind_2 = ikind;
3204 if (expr->value.op.op1->ts.type == BT_INTEGER)
3206 lse.expr = convert (gfc_int4_type_node, lse.expr);
3233 switch (expr->value.op.op1->ts.type)
3236 if (kind == 3) /* Case 16 was not handled properly above. */
3238 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3242 /* Use builtins for real ** int4. */
3248 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3252 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3256 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3260 /* Use the __builtin_powil() only if real(kind=16) is
3261 actually the C long double type. */
3262 if (!gfc_real16_is_float128)
3263 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3271 /* If we don't have a good builtin for this, go for the
3272 library function. */
3274 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3278 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3287 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3291 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3299 se->expr = build_call_expr_loc (input_location,
3300 fndecl, 2, lse.expr, rse.expr);
3302 /* Convert the result back if it is of wrong integer kind. */
3303 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3305 /* We want the maximum of both operand kinds as result. */
3306 if (res_ikind_1 < res_ikind_2)
3307 res_ikind_1 = res_ikind_2;
3308 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3313 /* Generate code to allocate a string temporary. */
3316 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3321 if (gfc_can_put_var_on_stack (len))
3323 /* Create a temporary variable to hold the result. */
3324 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3325 TREE_TYPE (len), len,
3326 build_int_cst (TREE_TYPE (len), 1));
3327 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3329 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3330 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3332 tmp = build_array_type (TREE_TYPE (type), tmp);
3334 var = gfc_create_var (tmp, "str");
3335 var = gfc_build_addr_expr (type, var);
3339 /* Allocate a temporary to hold the result. */
3340 var = gfc_create_var (type, "pstr");
3341 gcc_assert (POINTER_TYPE_P (type));
3342 tmp = TREE_TYPE (type);
3343 if (TREE_CODE (tmp) == ARRAY_TYPE)
3344 tmp = TREE_TYPE (tmp);
3345 tmp = TYPE_SIZE_UNIT (tmp);
3346 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3347 fold_convert (size_type_node, len),
3348 fold_convert (size_type_node, tmp));
3349 tmp = gfc_call_malloc (&se->pre, type, tmp);
3350 gfc_add_modify (&se->pre, var, tmp);
3352 /* Free the temporary afterwards. */
3353 tmp = gfc_call_free (var);
3354 gfc_add_expr_to_block (&se->post, tmp);
3361 /* Handle a string concatenation operation. A temporary will be allocated to
3365 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3368 tree len, type, var, tmp, fndecl;
3370 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3371 && expr->value.op.op2->ts.type == BT_CHARACTER);
3372 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3374 gfc_init_se (&lse, se);
3375 gfc_conv_expr (&lse, expr->value.op.op1);
3376 gfc_conv_string_parameter (&lse);
3377 gfc_init_se (&rse, se);
3378 gfc_conv_expr (&rse, expr->value.op.op2);
3379 gfc_conv_string_parameter (&rse);
3381 gfc_add_block_to_block (&se->pre, &lse.pre);
3382 gfc_add_block_to_block (&se->pre, &rse.pre);
3384 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3385 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3386 if (len == NULL_TREE)
3388 len = fold_build2_loc (input_location, PLUS_EXPR,
3389 gfc_charlen_type_node,
3390 fold_convert (gfc_charlen_type_node,
3392 fold_convert (gfc_charlen_type_node,
3393 rse.string_length));
3396 type = build_pointer_type (type);
3398 var = gfc_conv_string_tmp (se, type, len);
3400 /* Do the actual concatenation. */
3401 if (expr->ts.kind == 1)
3402 fndecl = gfor_fndecl_concat_string;
3403 else if (expr->ts.kind == 4)
3404 fndecl = gfor_fndecl_concat_string_char4;
3408 tmp = build_call_expr_loc (input_location,
3409 fndecl, 6, len, var, lse.string_length, lse.expr,
3410 rse.string_length, rse.expr);
3411 gfc_add_expr_to_block (&se->pre, tmp);
3413 /* Add the cleanup for the operands. */
3414 gfc_add_block_to_block (&se->pre, &rse.post);
3415 gfc_add_block_to_block (&se->pre, &lse.post);
3418 se->string_length = len;
3421 /* Translates an op expression. Common (binary) cases are handled by this
3422 function, others are passed on. Recursion is used in either case.
3423 We use the fact that (op1.ts == op2.ts) (except for the power
3425 Operators need no special handling for scalarized expressions as long as
3426 they call gfc_conv_simple_val to get their operands.
3427 Character strings get special handling. */
3430 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3432 enum tree_code code;
3441 switch (expr->value.op.op)
3443 case INTRINSIC_PARENTHESES:
3444 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3445 && flag_protect_parens)
3447 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3448 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3453 case INTRINSIC_UPLUS:
3454 gfc_conv_expr (se, expr->value.op.op1);
3457 case INTRINSIC_UMINUS:
3458 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3462 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3465 case INTRINSIC_PLUS:
3469 case INTRINSIC_MINUS:
3473 case INTRINSIC_TIMES:
3477 case INTRINSIC_DIVIDE:
3478 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3479 an integer, we must round towards zero, so we use a
3481 if (expr->ts.type == BT_INTEGER)
3482 code = TRUNC_DIV_EXPR;
3487 case INTRINSIC_POWER:
3488 gfc_conv_power_op (se, expr);
3491 case INTRINSIC_CONCAT:
3492 gfc_conv_concat_op (se, expr);
3496 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3501 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3505 /* EQV and NEQV only work on logicals, but since we represent them
3506 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3508 case INTRINSIC_EQ_OS:
3516 case INTRINSIC_NE_OS:
3517 case INTRINSIC_NEQV:
3524 case INTRINSIC_GT_OS:
3531 case INTRINSIC_GE_OS:
3538 case INTRINSIC_LT_OS:
3545 case INTRINSIC_LE_OS:
3551 case INTRINSIC_USER:
3552 case INTRINSIC_ASSIGN:
3553 /* These should be converted into function calls by the frontend. */
3557 fatal_error (input_location, "Unknown intrinsic op");
3561 /* The only exception to this is **, which is handled separately anyway. */
3562 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3564 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3568 gfc_init_se (&lse, se);
3569 gfc_conv_expr (&lse, expr->value.op.op1);
3570 gfc_add_block_to_block (&se->pre, &lse.pre);
3573 gfc_init_se (&rse, se);
3574 gfc_conv_expr (&rse, expr->value.op.op2);
3575 gfc_add_block_to_block (&se->pre, &rse.pre);
3579 gfc_conv_string_parameter (&lse);
3580 gfc_conv_string_parameter (&rse);
3582 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3583 rse.string_length, rse.expr,
3584 expr->value.op.op1->ts.kind,
3586 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3587 gfc_add_block_to_block (&lse.post, &rse.post);
3590 type = gfc_typenode_for_spec (&expr->ts);
3594 /* The result of logical ops is always logical_type_node. */
3595 tmp = fold_build2_loc (input_location, code, logical_type_node,
3596 lse.expr, rse.expr);
3597 se->expr = convert (type, tmp);
3600 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3602 /* Add the post blocks. */
3603 gfc_add_block_to_block (&se->post, &rse.post);
3604 gfc_add_block_to_block (&se->post, &lse.post);
3607 /* If a string's length is one, we convert it to a single character. */
3610 gfc_string_to_single_character (tree len, tree str, int kind)
3614 || !tree_fits_uhwi_p (len)
3615 || !POINTER_TYPE_P (TREE_TYPE (str)))
3618 if (TREE_INT_CST_LOW (len) == 1)
3620 str = fold_convert (gfc_get_pchar_type (kind), str);
3621 return build_fold_indirect_ref_loc (input_location, str);
3625 && TREE_CODE (str) == ADDR_EXPR
3626 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3627 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3628 && array_ref_low_bound (TREE_OPERAND (str, 0))
3629 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3630 && TREE_INT_CST_LOW (len) > 1
3631 && TREE_INT_CST_LOW (len)
3632 == (unsigned HOST_WIDE_INT)
3633 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3635 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3636 ret = build_fold_indirect_ref_loc (input_location, ret);
3637 if (TREE_CODE (ret) == INTEGER_CST)
3639 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3640 int i, length = TREE_STRING_LENGTH (string_cst);
3641 const char *ptr = TREE_STRING_POINTER (string_cst);
3643 for (i = 1; i < length; i++)
3656 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3659 if (sym->backend_decl)
3661 /* This becomes the nominal_type in
3662 function.c:assign_parm_find_data_types. */
3663 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3664 /* This becomes the passed_type in
3665 function.c:assign_parm_find_data_types. C promotes char to
3666 integer for argument passing. */
3667 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3669 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3674 /* If we have a constant character expression, make it into an
3676 if ((*expr)->expr_type == EXPR_CONSTANT)
3681 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3682 (int)(*expr)->value.character.string[0]);
3683 if ((*expr)->ts.kind != gfc_c_int_kind)
3685 /* The expr needs to be compatible with a C int. If the
3686 conversion fails, then the 2 causes an ICE. */
3687 ts.type = BT_INTEGER;
3688 ts.kind = gfc_c_int_kind;
3689 gfc_convert_type (*expr, &ts, 2);
3692 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3694 if ((*expr)->ref == NULL)
3696 se->expr = gfc_string_to_single_character
3697 (build_int_cst (integer_type_node, 1),
3698 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3700 ((*expr)->symtree->n.sym)),
3705 gfc_conv_variable (se, *expr);
3706 se->expr = gfc_string_to_single_character
3707 (build_int_cst (integer_type_node, 1),
3708 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3716 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3717 if STR is a string literal, otherwise return -1. */
3720 gfc_optimize_len_trim (tree len, tree str, int kind)
3723 && TREE_CODE (str) == ADDR_EXPR
3724 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3725 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3726 && array_ref_low_bound (TREE_OPERAND (str, 0))
3727 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3728 && tree_fits_uhwi_p (len)
3729 && tree_to_uhwi (len) >= 1
3730 && tree_to_uhwi (len)
3731 == (unsigned HOST_WIDE_INT)
3732 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3734 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3735 folded = build_fold_indirect_ref_loc (input_location, folded);
3736 if (TREE_CODE (folded) == INTEGER_CST)
3738 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3739 int length = TREE_STRING_LENGTH (string_cst);
3740 const char *ptr = TREE_STRING_POINTER (string_cst);
3742 for (; length > 0; length--)
3743 if (ptr[length - 1] != ' ')
3752 /* Helper to build a call to memcmp. */
3755 build_memcmp_call (tree s1, tree s2, tree n)
3759 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3760 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3762 s1 = fold_convert (pvoid_type_node, s1);
3764 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3765 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3767 s2 = fold_convert (pvoid_type_node, s2);
3769 n = fold_convert (size_type_node, n);
3771 tmp = build_call_expr_loc (input_location,
3772 builtin_decl_explicit (BUILT_IN_MEMCMP),
3775 return fold_convert (integer_type_node, tmp);
3778 /* Compare two strings. If they are all single characters, the result is the
3779 subtraction of them. Otherwise, we build a library call. */
3782 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3783 enum tree_code code)
3789 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3790 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3792 sc1 = gfc_string_to_single_character (len1, str1, kind);
3793 sc2 = gfc_string_to_single_character (len2, str2, kind);
3795 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3797 /* Deal with single character specially. */
3798 sc1 = fold_convert (integer_type_node, sc1);
3799 sc2 = fold_convert (integer_type_node, sc2);
3800 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3804 if ((code == EQ_EXPR || code == NE_EXPR)
3806 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3808 /* If one string is a string literal with LEN_TRIM longer
3809 than the length of the second string, the strings
3811 int len = gfc_optimize_len_trim (len1, str1, kind);
3812 if (len > 0 && compare_tree_int (len2, len) < 0)
3813 return integer_one_node;
3814 len = gfc_optimize_len_trim (len2, str2, kind);
3815 if (len > 0 && compare_tree_int (len1, len) < 0)
3816 return integer_one_node;
3819 /* We can compare via memcpy if the strings are known to be equal
3820 in length and they are
3822 - kind=4 and the comparison is for (in)equality. */
3824 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3825 && tree_int_cst_equal (len1, len2)
3826 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3831 chartype = gfc_get_char_type (kind);
3832 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3833 fold_convert (TREE_TYPE(len1),
3834 TYPE_SIZE_UNIT(chartype)),
3836 return build_memcmp_call (str1, str2, tmp);
3839 /* Build a call for the comparison. */
3841 fndecl = gfor_fndecl_compare_string;
3843 fndecl = gfor_fndecl_compare_string_char4;
3847 return build_call_expr_loc (input_location, fndecl, 4,
3848 len1, str1, len2, str2);
3852 /* Return the backend_decl for a procedure pointer component. */
3855 get_proc_ptr_comp (gfc_expr *e)
3861 gfc_init_se (&comp_se, NULL);
3862 e2 = gfc_copy_expr (e);
3863 /* We have to restore the expr type later so that gfc_free_expr frees
3864 the exact same thing that was allocated.
3865 TODO: This is ugly. */
3866 old_type = e2->expr_type;
3867 e2->expr_type = EXPR_VARIABLE;
3868 gfc_conv_expr (&comp_se, e2);
3869 e2->expr_type = old_type;
3871 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3875 /* Convert a typebound function reference from a class object. */
3877 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3882 if (!VAR_P (base_object))
3884 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3885 gfc_add_modify (&se->pre, var, base_object);
3887 se->expr = gfc_class_vptr_get (base_object);
3888 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3890 while (ref && ref->next)
3892 gcc_assert (ref && ref->type == REF_COMPONENT);
3893 if (ref->u.c.sym->attr.extension)
3894 conv_parent_component_references (se, ref);
3895 gfc_conv_component_ref (se, ref);
3896 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3901 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
3902 gfc_actual_arglist *actual_args)
3906 if (gfc_is_proc_ptr_comp (expr))
3907 tmp = get_proc_ptr_comp (expr);
3908 else if (sym->attr.dummy)
3910 tmp = gfc_get_symbol_decl (sym);
3911 if (sym->attr.proc_pointer)
3912 tmp = build_fold_indirect_ref_loc (input_location,
3914 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3915 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3919 if (!sym->backend_decl)
3920 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
3922 TREE_USED (sym->backend_decl) = 1;
3924 tmp = sym->backend_decl;
3926 if (sym->attr.cray_pointee)
3928 /* TODO - make the cray pointee a pointer to a procedure,
3929 assign the pointer to it and use it for the call. This
3931 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3932 gfc_get_symbol_decl (sym->cp_pointer));
3933 tmp = gfc_evaluate_now (tmp, &se->pre);
3936 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3938 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3939 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3946 /* Initialize MAPPING. */
3949 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3951 mapping->syms = NULL;
3952 mapping->charlens = NULL;
3956 /* Free all memory held by MAPPING (but not MAPPING itself). */
3959 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3961 gfc_interface_sym_mapping *sym;
3962 gfc_interface_sym_mapping *nextsym;
3964 gfc_charlen *nextcl;
3966 for (sym = mapping->syms; sym; sym = nextsym)
3968 nextsym = sym->next;
3969 sym->new_sym->n.sym->formal = NULL;
3970 gfc_free_symbol (sym->new_sym->n.sym);
3971 gfc_free_expr (sym->expr);
3972 free (sym->new_sym);
3975 for (cl = mapping->charlens; cl; cl = nextcl)
3978 gfc_free_expr (cl->length);
3984 /* Return a copy of gfc_charlen CL. Add the returned structure to
3985 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3987 static gfc_charlen *
3988 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3991 gfc_charlen *new_charlen;
3993 new_charlen = gfc_get_charlen ();
3994 new_charlen->next = mapping->charlens;
3995 new_charlen->length = gfc_copy_expr (cl->length);
3997 mapping->charlens = new_charlen;
4002 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4003 array variable that can be used as the actual argument for dummy
4004 argument SYM. Add any initialization code to BLOCK. PACKED is as
4005 for gfc_get_nodesc_array_type and DATA points to the first element
4006 in the passed array. */
4009 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4010 gfc_packed packed, tree data)
4015 type = gfc_typenode_for_spec (&sym->ts);
4016 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4017 !sym->attr.target && !sym->attr.pointer
4018 && !sym->attr.proc_pointer);
4020 var = gfc_create_var (type, "ifm");
4021 gfc_add_modify (block, var, fold_convert (type, data));
4027 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4028 and offset of descriptorless array type TYPE given that it has the same
4029 size as DESC. Add any set-up code to BLOCK. */
4032 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4039 offset = gfc_index_zero_node;
4040 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4042 dim = gfc_rank_cst[n];
4043 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4044 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4046 GFC_TYPE_ARRAY_LBOUND (type, n)
4047 = gfc_conv_descriptor_lbound_get (desc, dim);
4048 GFC_TYPE_ARRAY_UBOUND (type, n)
4049 = gfc_conv_descriptor_ubound_get (desc, dim);
4051 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4053 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4054 gfc_array_index_type,
4055 gfc_conv_descriptor_ubound_get (desc, dim),
4056 gfc_conv_descriptor_lbound_get (desc, dim));
4057 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4058 gfc_array_index_type,
4059 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4060 tmp = gfc_evaluate_now (tmp, block);
4061 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4063 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4064 GFC_TYPE_ARRAY_LBOUND (type, n),
4065 GFC_TYPE_ARRAY_STRIDE (type, n));
4066 offset = fold_build2_loc (input_location, MINUS_EXPR,
4067 gfc_array_index_type, offset, tmp);
4069 offset = gfc_evaluate_now (offset, block);
4070 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4074 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4075 in SE. The caller may still use se->expr and se->string_length after
4076 calling this function. */
4079 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4080 gfc_symbol * sym, gfc_se * se,
4083 gfc_interface_sym_mapping *sm;
4087 gfc_symbol *new_sym;
4089 gfc_symtree *new_symtree;
4091 /* Create a new symbol to represent the actual argument. */
4092 new_sym = gfc_new_symbol (sym->name, NULL);
4093 new_sym->ts = sym->ts;
4094 new_sym->as = gfc_copy_array_spec (sym->as);
4095 new_sym->attr.referenced = 1;
4096 new_sym->attr.dimension = sym->attr.dimension;
4097 new_sym->attr.contiguous = sym->attr.contiguous;
4098 new_sym->attr.codimension = sym->attr.codimension;
4099 new_sym->attr.pointer = sym->attr.pointer;
4100 new_sym->attr.allocatable = sym->attr.allocatable;
4101 new_sym->attr.flavor = sym->attr.flavor;
4102 new_sym->attr.function = sym->attr.function;
4104 /* Ensure that the interface is available and that
4105 descriptors are passed for array actual arguments. */
4106 if (sym->attr.flavor == FL_PROCEDURE)
4108 new_sym->formal = expr->symtree->n.sym->formal;
4109 new_sym->attr.always_explicit
4110 = expr->symtree->n.sym->attr.always_explicit;
4113 /* Create a fake symtree for it. */
4115 new_symtree = gfc_new_symtree (&root, sym->name);
4116 new_symtree->n.sym = new_sym;
4117 gcc_assert (new_symtree == root);
4119 /* Create a dummy->actual mapping. */
4120 sm = XCNEW (gfc_interface_sym_mapping);
4121 sm->next = mapping->syms;
4123 sm->new_sym = new_symtree;
4124 sm->expr = gfc_copy_expr (expr);
4127 /* Stabilize the argument's value. */
4128 if (!sym->attr.function && se)
4129 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4131 if (sym->ts.type == BT_CHARACTER)
4133 /* Create a copy of the dummy argument's length. */
4134 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4135 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4137 /* If the length is specified as "*", record the length that
4138 the caller is passing. We should use the callee's length
4139 in all other cases. */
4140 if (!new_sym->ts.u.cl->length && se)
4142 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4143 new_sym->ts.u.cl->backend_decl = se->string_length;
4150 /* Use the passed value as-is if the argument is a function. */
4151 if (sym->attr.flavor == FL_PROCEDURE)
4154 /* If the argument is a pass-by-value scalar, use the value as is. */
4155 else if (!sym->attr.dimension && sym->attr.value)
4158 /* If the argument is either a string or a pointer to a string,
4159 convert it to a boundless character type. */
4160 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4162 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4163 tmp = build_pointer_type (tmp);
4164 if (sym->attr.pointer)
4165 value = build_fold_indirect_ref_loc (input_location,
4169 value = fold_convert (tmp, value);
4172 /* If the argument is a scalar, a pointer to an array or an allocatable,
4174 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4175 value = build_fold_indirect_ref_loc (input_location,
4178 /* For character(*), use the actual argument's descriptor. */
4179 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4180 value = build_fold_indirect_ref_loc (input_location,
4183 /* If the argument is an array descriptor, use it to determine
4184 information about the actual argument's shape. */
4185 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4186 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4188 /* Get the actual argument's descriptor. */
4189 desc = build_fold_indirect_ref_loc (input_location,
4192 /* Create the replacement variable. */
4193 tmp = gfc_conv_descriptor_data_get (desc);
4194 value = gfc_get_interface_mapping_array (&se->pre, sym,
4197 /* Use DESC to work out the upper bounds, strides and offset. */
4198 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4201 /* Otherwise we have a packed array. */
4202 value = gfc_get_interface_mapping_array (&se->pre, sym,
4203 PACKED_FULL, se->expr);
4205 new_sym->backend_decl = value;
4209 /* Called once all dummy argument mappings have been added to MAPPING,
4210 but before the mapping is used to evaluate expressions. Pre-evaluate
4211 the length of each argument, adding any initialization code to PRE and
4212 any finalization code to POST. */
4215 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4216 stmtblock_t * pre, stmtblock_t * post)
4218 gfc_interface_sym_mapping *sym;
4222 for (sym = mapping->syms; sym; sym = sym->next)
4223 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4224 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4226 expr = sym->new_sym->n.sym->ts.u.cl->length;
4227 gfc_apply_interface_mapping_to_expr (mapping, expr);
4228 gfc_init_se (&se, NULL);
4229 gfc_conv_expr (&se, expr);
4230 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4231 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4232 gfc_add_block_to_block (pre, &se.pre);
4233 gfc_add_block_to_block (post, &se.post);
4235 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4240 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4244 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4245 gfc_constructor_base base)
4248 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4250 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4253 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4254 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4255 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4261 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4265 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4270 for (; ref; ref = ref->next)
4274 for (n = 0; n < ref->u.ar.dimen; n++)
4276 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4277 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4278 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4287 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4288 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4294 /* Convert intrinsic function calls into result expressions. */
4297 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4305 arg1 = expr->value.function.actual->expr;
4306 if (expr->value.function.actual->next)
4307 arg2 = expr->value.function.actual->next->expr;
4311 sym = arg1->symtree->n.sym;
4313 if (sym->attr.dummy)
4318 switch (expr->value.function.isym->id)
4321 /* TODO figure out why this condition is necessary. */
4322 if (sym->attr.function
4323 && (arg1->ts.u.cl->length == NULL
4324 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4325 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4328 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4331 case GFC_ISYM_LEN_TRIM:
4332 new_expr = gfc_copy_expr (arg1);
4333 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4338 gfc_replace_expr (arg1, new_expr);
4342 if (!sym->as || sym->as->rank == 0)
4345 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4347 dup = mpz_get_si (arg2->value.integer);
4352 dup = sym->as->rank;
4356 for (; d < dup; d++)
4360 if (!sym->as->upper[d] || !sym->as->lower[d])
4362 gfc_free_expr (new_expr);
4366 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4367 gfc_get_int_expr (gfc_default_integer_kind,
4369 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4371 new_expr = gfc_multiply (new_expr, tmp);
4377 case GFC_ISYM_LBOUND:
4378 case GFC_ISYM_UBOUND:
4379 /* TODO These implementations of lbound and ubound do not limit if
4380 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4382 if (!sym->as || sym->as->rank == 0)
4385 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4386 d = mpz_get_si (arg2->value.integer) - 1;
4390 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4392 if (sym->as->lower[d])
4393 new_expr = gfc_copy_expr (sym->as->lower[d]);
4397 if (sym->as->upper[d])
4398 new_expr = gfc_copy_expr (sym->as->upper[d]);
4406 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4410 gfc_replace_expr (expr, new_expr);
4416 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4417 gfc_interface_mapping * mapping)
4419 gfc_formal_arglist *f;
4420 gfc_actual_arglist *actual;
4422 actual = expr->value.function.actual;
4423 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4425 for (; f && actual; f = f->next, actual = actual->next)
4430 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4433 if (map_expr->symtree->n.sym->attr.dimension)
4438 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4440 for (d = 0; d < as->rank; d++)
4442 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4443 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4446 expr->value.function.esym->as = as;
4449 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4451 expr->value.function.esym->ts.u.cl->length
4452 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4454 gfc_apply_interface_mapping_to_expr (mapping,
4455 expr->value.function.esym->ts.u.cl->length);
4460 /* EXPR is a copy of an expression that appeared in the interface
4461 associated with MAPPING. Walk it recursively looking for references to
4462 dummy arguments that MAPPING maps to actual arguments. Replace each such
4463 reference with a reference to the associated actual argument. */
4466 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4469 gfc_interface_sym_mapping *sym;
4470 gfc_actual_arglist *actual;
4475 /* Copying an expression does not copy its length, so do that here. */
4476 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4478 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4479 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4482 /* Apply the mapping to any references. */
4483 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4485 /* ...and to the expression's symbol, if it has one. */
4486 /* TODO Find out why the condition on expr->symtree had to be moved into
4487 the loop rather than being outside it, as originally. */
4488 for (sym = mapping->syms; sym; sym = sym->next)
4489 if (expr->symtree && sym->old == expr->symtree->n.sym)
4491 if (sym->new_sym->n.sym->backend_decl)
4492 expr->symtree = sym->new_sym;
4494 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4497 /* ...and to subexpressions in expr->value. */
4498 switch (expr->expr_type)
4503 case EXPR_SUBSTRING:
4507 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4508 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4512 for (actual = expr->value.function.actual; actual; actual = actual->next)
4513 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4515 if (expr->value.function.esym == NULL
4516 && expr->value.function.isym != NULL
4517 && expr->value.function.actual
4518 && expr->value.function.actual->expr
4519 && expr->value.function.actual->expr->symtree
4520 && gfc_map_intrinsic_function (expr, mapping))
4523 for (sym = mapping->syms; sym; sym = sym->next)
4524 if (sym->old == expr->value.function.esym)
4526 expr->value.function.esym = sym->new_sym->n.sym;
4527 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4528 expr->value.function.esym->result = sym->new_sym->n.sym;
4533 case EXPR_STRUCTURE:
4534 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4547 /* Evaluate interface expression EXPR using MAPPING. Store the result
4551 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4552 gfc_se * se, gfc_expr * expr)
4554 expr = gfc_copy_expr (expr);
4555 gfc_apply_interface_mapping_to_expr (mapping, expr);
4556 gfc_conv_expr (se, expr);
4557 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4558 gfc_free_expr (expr);
4562 /* Returns a reference to a temporary array into which a component of
4563 an actual argument derived type array is copied and then returned
4564 after the function call. */
4566 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4567 sym_intent intent, bool formal_ptr)
4575 gfc_array_info *info;
4585 gfc_init_se (&lse, NULL);
4586 gfc_init_se (&rse, NULL);
4588 /* Walk the argument expression. */
4589 rss = gfc_walk_expr (expr);
4591 gcc_assert (rss != gfc_ss_terminator);
4593 /* Initialize the scalarizer. */
4594 gfc_init_loopinfo (&loop);
4595 gfc_add_ss_to_loop (&loop, rss);
4597 /* Calculate the bounds of the scalarization. */
4598 gfc_conv_ss_startstride (&loop);
4600 /* Build an ss for the temporary. */
4601 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4602 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4604 base_type = gfc_typenode_for_spec (&expr->ts);
4605 if (GFC_ARRAY_TYPE_P (base_type)
4606 || GFC_DESCRIPTOR_TYPE_P (base_type))
4607 base_type = gfc_get_element_type (base_type);
4609 if (expr->ts.type == BT_CLASS)
4610 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4612 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4613 ? expr->ts.u.cl->backend_decl
4617 parmse->string_length = loop.temp_ss->info->string_length;
4619 /* Associate the SS with the loop. */
4620 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4622 /* Setup the scalarizing loops. */
4623 gfc_conv_loop_setup (&loop, &expr->where);
4625 /* Pass the temporary descriptor back to the caller. */
4626 info = &loop.temp_ss->info->data.array;
4627 parmse->expr = info->descriptor;
4629 /* Setup the gfc_se structures. */
4630 gfc_copy_loopinfo_to_se (&lse, &loop);
4631 gfc_copy_loopinfo_to_se (&rse, &loop);
4634 lse.ss = loop.temp_ss;
4635 gfc_mark_ss_chain_used (rss, 1);
4636 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4638 /* Start the scalarized loop body. */
4639 gfc_start_scalarized_body (&loop, &body);
4641 /* Translate the expression. */
4642 gfc_conv_expr (&rse, expr);
4644 /* Reset the offset for the function call since the loop
4645 is zero based on the data pointer. Note that the temp
4646 comes first in the loop chain since it is added second. */
4647 if (gfc_is_class_array_function (expr))
4649 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4650 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4651 gfc_index_zero_node);
4654 gfc_conv_tmp_array_ref (&lse);
4656 if (intent != INTENT_OUT)
4658 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4659 gfc_add_expr_to_block (&body, tmp);
4660 gcc_assert (rse.ss == gfc_ss_terminator);
4661 gfc_trans_scalarizing_loops (&loop, &body);
4665 /* Make sure that the temporary declaration survives by merging
4666 all the loop declarations into the current context. */
4667 for (n = 0; n < loop.dimen; n++)
4669 gfc_merge_block_scope (&body);
4670 body = loop.code[loop.order[n]];
4672 gfc_merge_block_scope (&body);
4675 /* Add the post block after the second loop, so that any
4676 freeing of allocated memory is done at the right time. */
4677 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4679 /**********Copy the temporary back again.*********/
4681 gfc_init_se (&lse, NULL);
4682 gfc_init_se (&rse, NULL);
4684 /* Walk the argument expression. */
4685 lss = gfc_walk_expr (expr);
4686 rse.ss = loop.temp_ss;
4689 /* Initialize the scalarizer. */
4690 gfc_init_loopinfo (&loop2);
4691 gfc_add_ss_to_loop (&loop2, lss);
4693 dimen = rse.ss->dimen;
4695 /* Skip the write-out loop for this case. */
4696 if (gfc_is_class_array_function (expr))
4697 goto class_array_fcn;
4699 /* Calculate the bounds of the scalarization. */
4700 gfc_conv_ss_startstride (&loop2);
4702 /* Setup the scalarizing loops. */
4703 gfc_conv_loop_setup (&loop2, &expr->where);
4705 gfc_copy_loopinfo_to_se (&lse, &loop2);
4706 gfc_copy_loopinfo_to_se (&rse, &loop2);
4708 gfc_mark_ss_chain_used (lss, 1);
4709 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4711 /* Declare the variable to hold the temporary offset and start the
4712 scalarized loop body. */
4713 offset = gfc_create_var (gfc_array_index_type, NULL);
4714 gfc_start_scalarized_body (&loop2, &body);
4716 /* Build the offsets for the temporary from the loop variables. The
4717 temporary array has lbounds of zero and strides of one in all
4718 dimensions, so this is very simple. The offset is only computed
4719 outside the innermost loop, so the overall transfer could be
4720 optimized further. */
4721 info = &rse.ss->info->data.array;
4723 tmp_index = gfc_index_zero_node;
4724 for (n = dimen - 1; n > 0; n--)
4727 tmp = rse.loop->loopvar[n];
4728 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4729 tmp, rse.loop->from[n]);
4730 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4733 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4734 gfc_array_index_type,
4735 rse.loop->to[n-1], rse.loop->from[n-1]);
4736 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4737 gfc_array_index_type,
4738 tmp_str, gfc_index_one_node);
4740 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4741 gfc_array_index_type, tmp, tmp_str);
4744 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4745 gfc_array_index_type,
4746 tmp_index, rse.loop->from[0]);
4747 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4749 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4750 gfc_array_index_type,
4751 rse.loop->loopvar[0], offset);
4753 /* Now use the offset for the reference. */
4754 tmp = build_fold_indirect_ref_loc (input_location,
4756 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4758 if (expr->ts.type == BT_CHARACTER)
4759 rse.string_length = expr->ts.u.cl->backend_decl;
4761 gfc_conv_expr (&lse, expr);
4763 gcc_assert (lse.ss == gfc_ss_terminator);
4765 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4766 gfc_add_expr_to_block (&body, tmp);
4768 /* Generate the copying loops. */
4769 gfc_trans_scalarizing_loops (&loop2, &body);
4771 /* Wrap the whole thing up by adding the second loop to the post-block
4772 and following it by the post-block of the first loop. In this way,
4773 if the temporary needs freeing, it is done after use! */
4774 if (intent != INTENT_IN)
4776 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4777 gfc_add_block_to_block (&parmse->post, &loop2.post);
4782 gfc_add_block_to_block (&parmse->post, &loop.post);
4784 gfc_cleanup_loop (&loop);
4785 gfc_cleanup_loop (&loop2);
4787 /* Pass the string length to the argument expression. */
4788 if (expr->ts.type == BT_CHARACTER)
4789 parmse->string_length = expr->ts.u.cl->backend_decl;
4791 /* Determine the offset for pointer formal arguments and set the
4795 size = gfc_index_one_node;
4796 offset = gfc_index_zero_node;
4797 for (n = 0; n < dimen; n++)
4799 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4801 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4802 gfc_array_index_type, tmp,
4803 gfc_index_one_node);
4804 gfc_conv_descriptor_ubound_set (&parmse->pre,
4808 gfc_conv_descriptor_lbound_set (&parmse->pre,
4811 gfc_index_one_node);
4812 size = gfc_evaluate_now (size, &parmse->pre);
4813 offset = fold_build2_loc (input_location, MINUS_EXPR,
4814 gfc_array_index_type,
4816 offset = gfc_evaluate_now (offset, &parmse->pre);
4817 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4818 gfc_array_index_type,
4819 rse.loop->to[n], rse.loop->from[n]);
4820 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4821 gfc_array_index_type,
4822 tmp, gfc_index_one_node);
4823 size = fold_build2_loc (input_location, MULT_EXPR,
4824 gfc_array_index_type, size, tmp);
4827 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4831 /* We want either the address for the data or the address of the descriptor,
4832 depending on the mode of passing array arguments. */
4834 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4836 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4842 /* Generate the code for argument list functions. */
4845 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4847 /* Pass by value for g77 %VAL(arg), pass the address
4848 indirectly for %LOC, else by reference. Thus %REF
4849 is a "do-nothing" and %LOC is the same as an F95
4851 if (strcmp (name, "%VAL") == 0)
4852 gfc_conv_expr (se, expr);
4853 else if (strcmp (name, "%LOC") == 0)
4855 gfc_conv_expr_reference (se, expr);
4856 se->expr = gfc_build_addr_expr (NULL, se->expr);
4858 else if (strcmp (name, "%REF") == 0)
4859 gfc_conv_expr_reference (se, expr);
4861 gfc_error ("Unknown argument list function at %L", &expr->where);
4865 /* This function tells whether the middle-end representation of the expression
4866 E given as input may point to data otherwise accessible through a variable
4868 It is assumed that the only expressions that may alias are variables,
4869 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4871 This function is used to decide whether freeing an expression's allocatable
4872 components is safe or should be avoided.
4874 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4875 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4876 is necessary because for array constructors, aliasing depends on how
4878 - If E is an array constructor used as argument to an elemental procedure,
4879 the array, which is generated through shallow copy by the scalarizer,
4880 is used directly and can alias the expressions it was copied from.
4881 - If E is an array constructor used as argument to a non-elemental
4882 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4883 the array as in the previous case, but then that array is used
4884 to initialize a new descriptor through deep copy. There is no alias
4885 possible in that case.
4886 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4890 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4894 if (e->expr_type == EXPR_VARIABLE)
4896 else if (e->expr_type == EXPR_FUNCTION)
4898 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4900 if (proc_ifc->result != NULL
4901 && ((proc_ifc->result->ts.type == BT_CLASS
4902 && proc_ifc->result->ts.u.derived->attr.is_class
4903 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4904 || proc_ifc->result->attr.pointer))
4909 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4912 for (c = gfc_constructor_first (e->value.constructor);
4913 c; c = gfc_constructor_next (c))
4915 && expr_may_alias_variables (c->expr, array_may_alias))
4922 /* Provide an interface between gfortran array descriptors and the F2018:18.4
4923 ISO_Fortran_binding array descriptors. */
4926 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
4931 tree ptr = NULL_TREE;
4935 symbol_attribute attr = gfc_expr_attr (e);
4937 /* If this is a full array or a scalar, the allocatable and pointer
4938 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
4940 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
4944 else if (attr.allocatable)
4950 if (fsym->attr.contiguous
4951 && !gfc_is_simply_contiguous (e, false, true))
4952 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
4953 fsym->attr.pointer);
4955 gfc_conv_expr_descriptor (parmse, e);
4957 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
4958 parmse->expr = build_fold_indirect_ref_loc (input_location,
4961 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
4962 the expression type is different from the descriptor type, then
4963 the offset must be found (eg. to a component ref or substring)
4964 and the dtype updated. Assumed type entities are only allowed
4965 to be dummies in Fortran. They therefore lack the decl specific
4966 appendiges and so must be treated differently from other fortran
4967 entities passed to CFI descriptors in the interface decl. */
4968 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
4971 if (type && DECL_ARTIFICIAL (parmse->expr)
4972 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
4974 /* Obtain the offset to the data. */
4975 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
4976 gfc_index_zero_node, true, e);
4978 /* Update the dtype. */
4979 gfc_add_modify (&parmse->pre,
4980 gfc_conv_descriptor_dtype (parmse->expr),
4981 gfc_get_dtype_rank_type (e->rank, type));
4983 else if (type == NULL_TREE
4984 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
4986 /* Make sure that the span is set for expressions where it
4987 might not have been done already. */
4988 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
4989 tmp = fold_convert (gfc_array_index_type, tmp);
4990 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
4993 /* INTENT(IN) requires a temporary for the data. Assumed types do not
4994 work with the standard temporary generation schemes. */
4995 if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
4997 /* Fix the descriptor and determine the size of the data. */
4998 parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
4999 size = build_call_expr_loc (input_location,
5000 gfor_fndecl_size0, 1,
5001 gfc_build_addr_expr (NULL, parmse->expr));
5002 size = fold_convert (size_type_node, size);
5003 tmp = gfc_conv_descriptor_span_get (parmse->expr);
5004 tmp = fold_convert (size_type_node, tmp);
5005 size = fold_build2_loc (input_location, MULT_EXPR,
5006 size_type_node, size, tmp);
5007 /* Fix the size and allocate. */
5008 size = gfc_evaluate_now (size, &parmse->pre);
5009 tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
5010 ptr = build_call_expr_loc (input_location, tmp, 1, size);
5011 ptr = gfc_evaluate_now (ptr, &parmse->pre);
5012 /* Copy the data to the temporary descriptor. */
5013 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
5014 tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
5015 gfc_conv_descriptor_data_get (parmse->expr),
5017 gfc_add_expr_to_block (&parmse->pre, tmp);
5019 /* The temporary 'ptr' is freed below. */
5020 gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
5026 gfc_conv_expr (parmse, e);
5028 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5029 parmse->expr = build_fold_indirect_ref_loc (input_location,
5032 /* Copy the scalar for INTENT(IN). */
5033 if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
5035 if (e->ts.type != BT_CHARACTER)
5036 parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
5039 /* The temporary string 'ptr' is freed below. */
5040 tmp = build_pointer_type (TREE_TYPE (parmse->expr));
5041 ptr = gfc_create_var (tmp, "str");
5042 tmp = build_call_expr_loc (input_location,
5043 builtin_decl_explicit (BUILT_IN_MALLOC),
5044 1, parmse->string_length);
5045 tmp = fold_convert (TREE_TYPE (ptr), tmp);
5046 gfc_add_modify (&parmse->pre, ptr, tmp);
5047 tmp = gfc_build_memcpy_call (ptr, parmse->expr,
5048 parmse->string_length);
5049 gfc_add_expr_to_block (&parmse->pre, tmp);
5054 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5055 parmse->expr, attr);
5058 /* Set the CFI attribute field. */
5059 tmp = gfc_conv_descriptor_attribute (parmse->expr);
5060 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5061 void_type_node, tmp,
5062 build_int_cst (TREE_TYPE (tmp), attribute));
5063 gfc_add_expr_to_block (&parmse->pre, tmp);
5065 /* Now pass the gfc_descriptor by reference. */
5066 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5068 /* Variables to point to the gfc and CFI descriptors. */
5069 gfc_desc_ptr = parmse->expr;
5070 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5072 /* Allocate the CFI descriptor and fill the fields. */
5073 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5074 tmp = build_call_expr_loc (input_location,
5075 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5076 gfc_add_expr_to_block (&parmse->pre, tmp);
5078 /* The CFI descriptor is passed to the bind_C procedure. */
5079 parmse->expr = cfi_desc_ptr;
5083 /* Free both the temporary data and the CFI descriptor for
5084 INTENT(IN) arrays. */
5085 tmp = gfc_call_free (ptr);
5086 gfc_prepend_expr_to_block (&parmse->post, tmp);
5087 tmp = gfc_call_free (cfi_desc_ptr);
5088 gfc_prepend_expr_to_block (&parmse->post, tmp);
5092 /* Transfer values back to gfc descriptor and free the CFI descriptor. */
5093 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5094 tmp = build_call_expr_loc (input_location,
5095 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5096 gfc_prepend_expr_to_block (&parmse->post, tmp);
5100 /* Generate code for a procedure call. Note can return se->post != NULL.
5101 If se->direct_byref is set then se->expr contains the return parameter.
5102 Return nonzero, if the call has alternate specifiers.
5103 'expr' is only needed for procedure pointer components. */
5106 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5107 gfc_actual_arglist * args, gfc_expr * expr,
5108 vec<tree, va_gc> *append_args)
5110 gfc_interface_mapping mapping;
5111 vec<tree, va_gc> *arglist;
5112 vec<tree, va_gc> *retargs;
5116 gfc_array_info *info;
5123 vec<tree, va_gc> *stringargs;
5124 vec<tree, va_gc> *optionalargs;
5126 gfc_formal_arglist *formal;
5127 gfc_actual_arglist *arg;
5128 int has_alternate_specifier = 0;
5129 bool need_interface_mapping;
5137 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5138 gfc_component *comp = NULL;
5145 optionalargs = NULL;
5150 comp = gfc_get_proc_ptr_comp (expr);
5152 bool elemental_proc = (comp
5153 && comp->ts.interface
5154 && comp->ts.interface->attr.elemental)
5155 || (comp && comp->attr.elemental)
5156 || sym->attr.elemental;
5160 if (!elemental_proc)
5162 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5163 if (se->ss->info->useflags)
5165 gcc_assert ((!comp && gfc_return_by_reference (sym)
5166 && sym->result->attr.dimension)
5167 || (comp && comp->attr.dimension)
5168 || gfc_is_class_array_function (expr));
5169 gcc_assert (se->loop != NULL);
5170 /* Access the previously obtained result. */
5171 gfc_conv_tmp_array_ref (se);
5175 info = &se->ss->info->data.array;
5180 gfc_init_block (&post);
5181 gfc_init_interface_mapping (&mapping);
5184 formal = gfc_sym_get_dummy_args (sym);
5185 need_interface_mapping = sym->attr.dimension ||
5186 (sym->ts.type == BT_CHARACTER
5187 && sym->ts.u.cl->length
5188 && sym->ts.u.cl->length->expr_type
5193 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5194 need_interface_mapping = comp->attr.dimension ||
5195 (comp->ts.type == BT_CHARACTER
5196 && comp->ts.u.cl->length
5197 && comp->ts.u.cl->length->expr_type
5201 base_object = NULL_TREE;
5202 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5203 is the third and fourth argument to such a function call a value
5204 denoting the number of elements to copy (i.e., most of the time the
5205 length of a deferred length string). */
5206 ulim_copy = (formal == NULL)
5207 && UNLIMITED_POLY (sym)
5208 && comp && (strcmp ("_copy", comp->name) == 0);
5210 /* Evaluate the arguments. */
5211 for (arg = args, argc = 0; arg != NULL;
5212 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5214 bool finalized = false;
5215 bool non_unity_length_string = false;
5218 fsym = formal ? formal->sym : NULL;
5219 parm_kind = MISSING;
5221 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5222 && (!fsym->ts.u.cl->length
5223 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5224 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5225 non_unity_length_string = true;
5227 /* If the procedure requires an explicit interface, the actual
5228 argument is passed according to the corresponding formal
5229 argument. If the corresponding formal argument is a POINTER,
5230 ALLOCATABLE or assumed shape, we do not use g77's calling
5231 convention, and pass the address of the array descriptor
5232 instead. Otherwise we use g77's calling convention, in other words
5233 pass the array data pointer without descriptor. */
5234 bool nodesc_arg = fsym != NULL
5235 && !(fsym->attr.pointer || fsym->attr.allocatable)
5237 && fsym->as->type != AS_ASSUMED_SHAPE
5238 && fsym->as->type != AS_ASSUMED_RANK;
5240 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5242 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5244 /* Class array expressions are sometimes coming completely unadorned
5245 with either arrayspec or _data component. Correct that here.
5246 OOP-TODO: Move this to the frontend. */
5247 if (e && e->expr_type == EXPR_VARIABLE
5249 && e->ts.type == BT_CLASS
5250 && (CLASS_DATA (e)->attr.codimension
5251 || CLASS_DATA (e)->attr.dimension))
5253 gfc_typespec temp_ts = e->ts;
5254 gfc_add_class_array_ref (e);
5260 if (se->ignore_optional)
5262 /* Some intrinsics have already been resolved to the correct
5266 else if (arg->label)
5268 has_alternate_specifier = 1;
5273 gfc_init_se (&parmse, NULL);
5275 /* For scalar arguments with VALUE attribute which are passed by
5276 value, pass "0" and a hidden argument gives the optional
5278 if (fsym && fsym->attr.optional && fsym->attr.value
5279 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5280 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5282 parmse.expr = fold_convert (gfc_sym_type (fsym),
5284 vec_safe_push (optionalargs, boolean_false_node);
5288 /* Pass a NULL pointer for an absent arg. */
5289 parmse.expr = null_pointer_node;
5290 if (arg->missing_arg_type == BT_CHARACTER)
5291 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5296 else if (arg->expr->expr_type == EXPR_NULL
5297 && fsym && !fsym->attr.pointer
5298 && (fsym->ts.type != BT_CLASS
5299 || !CLASS_DATA (fsym)->attr.class_pointer))
5301 /* Pass a NULL pointer to denote an absent arg. */
5302 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5303 && (fsym->ts.type != BT_CLASS
5304 || !CLASS_DATA (fsym)->attr.allocatable));
5305 gfc_init_se (&parmse, NULL);
5306 parmse.expr = null_pointer_node;
5307 if (arg->missing_arg_type == BT_CHARACTER)
5308 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5310 else if (fsym && fsym->ts.type == BT_CLASS
5311 && e->ts.type == BT_DERIVED)
5313 /* The derived type needs to be converted to a temporary
5315 gfc_init_se (&parmse, se);
5316 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5318 && e->expr_type == EXPR_VARIABLE
5319 && e->symtree->n.sym->attr.optional,
5320 CLASS_DATA (fsym)->attr.class_pointer
5321 || CLASS_DATA (fsym)->attr.allocatable);
5323 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5325 /* The intrinsic type needs to be converted to a temporary
5326 CLASS object for the unlimited polymorphic formal. */
5327 gfc_init_se (&parmse, se);
5328 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5330 else if (se->ss && se->ss->info->useflags)
5336 /* An elemental function inside a scalarized loop. */
5337 gfc_init_se (&parmse, se);
5338 parm_kind = ELEMENTAL;
5340 /* When no fsym is present, ulim_copy is set and this is a third or
5341 fourth argument, use call-by-value instead of by reference to
5342 hand the length properties to the copy routine (i.e., most of the
5343 time this will be a call to a __copy_character_* routine where the
5344 third and fourth arguments are the lengths of a deferred length
5346 if ((fsym && fsym->attr.value)
5347 || (ulim_copy && (argc == 2 || argc == 3)))
5348 gfc_conv_expr (&parmse, e);
5350 gfc_conv_expr_reference (&parmse, e);
5352 if (e->ts.type == BT_CHARACTER && !e->rank
5353 && e->expr_type == EXPR_FUNCTION)
5354 parmse.expr = build_fold_indirect_ref_loc (input_location,
5357 if (fsym && fsym->ts.type == BT_DERIVED
5358 && gfc_is_class_container_ref (e))
5360 parmse.expr = gfc_class_data_get (parmse.expr);
5362 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5363 && e->symtree->n.sym->attr.optional)
5365 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5366 parmse.expr = build3_loc (input_location, COND_EXPR,
5367 TREE_TYPE (parmse.expr),
5369 fold_convert (TREE_TYPE (parmse.expr),
5370 null_pointer_node));
5374 /* If we are passing an absent array as optional dummy to an
5375 elemental procedure, make sure that we pass NULL when the data
5376 pointer is NULL. We need this extra conditional because of
5377 scalarization which passes arrays elements to the procedure,
5378 ignoring the fact that the array can be absent/unallocated/... */
5379 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5381 tree descriptor_data;
5383 descriptor_data = ss->info->data.array.data;
5384 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5386 fold_convert (TREE_TYPE (descriptor_data),
5387 null_pointer_node));
5389 = fold_build3_loc (input_location, COND_EXPR,
5390 TREE_TYPE (parmse.expr),
5391 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5392 fold_convert (TREE_TYPE (parmse.expr),
5397 /* The scalarizer does not repackage the reference to a class
5398 array - instead it returns a pointer to the data element. */
5399 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5400 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5401 fsym->attr.intent != INTENT_IN
5402 && (CLASS_DATA (fsym)->attr.class_pointer
5403 || CLASS_DATA (fsym)->attr.allocatable),
5405 && e->expr_type == EXPR_VARIABLE
5406 && e->symtree->n.sym->attr.optional,
5407 CLASS_DATA (fsym)->attr.class_pointer
5408 || CLASS_DATA (fsym)->attr.allocatable);
5415 gfc_init_se (&parmse, NULL);
5417 /* Check whether the expression is a scalar or not; we cannot use
5418 e->rank as it can be nonzero for functions arguments. */
5419 argss = gfc_walk_expr (e);
5420 scalar = argss == gfc_ss_terminator;
5422 gfc_free_ss_chain (argss);
5424 /* Special handling for passing scalar polymorphic coarrays;
5425 otherwise one passes "class->_data.data" instead of "&class". */
5426 if (e->rank == 0 && e->ts.type == BT_CLASS
5427 && fsym && fsym->ts.type == BT_CLASS
5428 && CLASS_DATA (fsym)->attr.codimension
5429 && !CLASS_DATA (fsym)->attr.dimension)
5431 gfc_add_class_array_ref (e);
5432 parmse.want_coarray = 1;
5436 /* A scalar or transformational function. */
5439 if (e->expr_type == EXPR_VARIABLE
5440 && e->symtree->n.sym->attr.cray_pointee
5441 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5443 /* The Cray pointer needs to be converted to a pointer to
5444 a type given by the expression. */
5445 gfc_conv_expr (&parmse, e);
5446 type = build_pointer_type (TREE_TYPE (parmse.expr));
5447 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5448 parmse.expr = convert (type, tmp);
5451 else if (sym->attr.is_bind_c && e
5452 && ((fsym && fsym->attr.dimension
5453 && (fsym->attr.pointer
5454 || fsym->attr.allocatable
5455 || fsym->as->type == AS_ASSUMED_RANK
5456 || fsym->as->type == AS_ASSUMED_SHAPE))
5457 || non_unity_length_string))
5458 /* Implement F2018, C.12.6.1: paragraph (2). */
5459 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5461 else if (fsym && fsym->attr.value)
5463 if (fsym->ts.type == BT_CHARACTER
5464 && fsym->ts.is_c_interop
5465 && fsym->ns->proc_name != NULL
5466 && fsym->ns->proc_name->attr.is_bind_c)
5469 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5470 if (parmse.expr == NULL)
5471 gfc_conv_expr (&parmse, e);
5475 gfc_conv_expr (&parmse, e);
5476 if (fsym->attr.optional
5477 && fsym->ts.type != BT_CLASS
5478 && fsym->ts.type != BT_DERIVED)
5480 if (e->expr_type != EXPR_VARIABLE
5481 || !e->symtree->n.sym->attr.optional
5483 vec_safe_push (optionalargs, boolean_true_node);
5486 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5487 if (!e->symtree->n.sym->attr.value)
5489 = fold_build3_loc (input_location, COND_EXPR,
5490 TREE_TYPE (parmse.expr),
5492 fold_convert (TREE_TYPE (parmse.expr),
5493 integer_zero_node));
5495 vec_safe_push (optionalargs, tmp);
5501 else if (arg->name && arg->name[0] == '%')
5502 /* Argument list functions %VAL, %LOC and %REF are signalled
5503 through arg->name. */
5504 conv_arglist_function (&parmse, arg->expr, arg->name);
5505 else if ((e->expr_type == EXPR_FUNCTION)
5506 && ((e->value.function.esym
5507 && e->value.function.esym->result->attr.pointer)
5508 || (!e->value.function.esym
5509 && e->symtree->n.sym->attr.pointer))
5510 && fsym && fsym->attr.target)
5512 gfc_conv_expr (&parmse, e);
5513 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5516 else if (e->expr_type == EXPR_FUNCTION
5517 && e->symtree->n.sym->result
5518 && e->symtree->n.sym->result != e->symtree->n.sym
5519 && e->symtree->n.sym->result->attr.proc_pointer)
5521 /* Functions returning procedure pointers. */
5522 gfc_conv_expr (&parmse, e);
5523 if (fsym && fsym->attr.proc_pointer)
5524 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5529 if (e->ts.type == BT_CLASS && fsym
5530 && fsym->ts.type == BT_CLASS
5531 && (!CLASS_DATA (fsym)->as
5532 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5533 && CLASS_DATA (e)->attr.codimension)
5535 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5536 gcc_assert (!CLASS_DATA (fsym)->as);
5537 gfc_add_class_array_ref (e);
5538 parmse.want_coarray = 1;
5539 gfc_conv_expr_reference (&parmse, e);
5540 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5542 && e->expr_type == EXPR_VARIABLE);
5544 else if (e->ts.type == BT_CLASS && fsym
5545 && fsym->ts.type == BT_CLASS
5546 && !CLASS_DATA (fsym)->as
5547 && !CLASS_DATA (e)->as
5548 && strcmp (fsym->ts.u.derived->name,
5549 e->ts.u.derived->name))
5551 type = gfc_typenode_for_spec (&fsym->ts);
5552 var = gfc_create_var (type, fsym->name);
5553 gfc_conv_expr (&parmse, e);
5554 if (fsym->attr.optional
5555 && e->expr_type == EXPR_VARIABLE
5556 && e->symtree->n.sym->attr.optional)
5560 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5561 cond = fold_build2_loc (input_location, NE_EXPR,
5562 logical_type_node, tmp,
5563 fold_convert (TREE_TYPE (tmp),
5564 null_pointer_node));
5565 gfc_start_block (&block);
5566 gfc_add_modify (&block, var,
5567 fold_build1_loc (input_location,
5569 type, parmse.expr));
5570 gfc_add_expr_to_block (&parmse.pre,
5571 fold_build3_loc (input_location,
5572 COND_EXPR, void_type_node,
5573 cond, gfc_finish_block (&block),
5574 build_empty_stmt (input_location)));
5575 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5576 parmse.expr = build3_loc (input_location, COND_EXPR,
5577 TREE_TYPE (parmse.expr),
5579 fold_convert (TREE_TYPE (parmse.expr),
5580 null_pointer_node));
5584 /* Since the internal representation of unlimited
5585 polymorphic expressions includes an extra field
5586 that other class objects do not, a cast to the
5587 formal type does not work. */
5588 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5592 /* Set the _data field. */
5593 tmp = gfc_class_data_get (var);
5594 efield = fold_convert (TREE_TYPE (tmp),
5595 gfc_class_data_get (parmse.expr));
5596 gfc_add_modify (&parmse.pre, tmp, efield);
5598 /* Set the _vptr field. */
5599 tmp = gfc_class_vptr_get (var);
5600 efield = fold_convert (TREE_TYPE (tmp),
5601 gfc_class_vptr_get (parmse.expr));
5602 gfc_add_modify (&parmse.pre, tmp, efield);
5604 /* Set the _len field. */
5605 tmp = gfc_class_len_get (var);
5606 gfc_add_modify (&parmse.pre, tmp,
5607 build_int_cst (TREE_TYPE (tmp), 0));
5611 tmp = fold_build1_loc (input_location,
5614 gfc_add_modify (&parmse.pre, var, tmp);
5617 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5623 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5624 && !fsym->attr.allocatable && !fsym->attr.pointer
5625 && !e->symtree->n.sym->attr.dimension
5626 && !e->symtree->n.sym->attr.pointer
5628 && !e->symtree->n.sym->attr.dummy
5629 /* FIXME - PR 87395 and PR 41453 */
5630 && e->symtree->n.sym->attr.save == SAVE_NONE
5631 && !e->symtree->n.sym->attr.associate_var
5632 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5633 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5635 gfc_conv_expr_reference (&parmse, e, add_clobber);
5637 /* Catch base objects that are not variables. */
5638 if (e->ts.type == BT_CLASS
5639 && e->expr_type != EXPR_VARIABLE
5640 && expr && e == expr->base_expr)
5641 base_object = build_fold_indirect_ref_loc (input_location,
5644 /* A class array element needs converting back to be a
5645 class object, if the formal argument is a class object. */
5646 if (fsym && fsym->ts.type == BT_CLASS
5647 && e->ts.type == BT_CLASS
5648 && ((CLASS_DATA (fsym)->as
5649 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5650 || CLASS_DATA (e)->attr.dimension))
5651 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5652 fsym->attr.intent != INTENT_IN
5653 && (CLASS_DATA (fsym)->attr.class_pointer
5654 || CLASS_DATA (fsym)->attr.allocatable),
5656 && e->expr_type == EXPR_VARIABLE
5657 && e->symtree->n.sym->attr.optional,
5658 CLASS_DATA (fsym)->attr.class_pointer
5659 || CLASS_DATA (fsym)->attr.allocatable);
5661 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5662 allocated on entry, it must be deallocated. */
5663 if (fsym && fsym->attr.intent == INTENT_OUT
5664 && (fsym->attr.allocatable
5665 || (fsym->ts.type == BT_CLASS
5666 && CLASS_DATA (fsym)->attr.allocatable)))
5671 gfc_init_block (&block);
5673 if (e->ts.type == BT_CLASS)
5674 ptr = gfc_class_data_get (ptr);
5676 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5679 gfc_add_expr_to_block (&block, tmp);
5680 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5681 void_type_node, ptr,
5683 gfc_add_expr_to_block (&block, tmp);
5685 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5687 gfc_add_modify (&block, ptr,
5688 fold_convert (TREE_TYPE (ptr),
5689 null_pointer_node));
5690 gfc_add_expr_to_block (&block, tmp);
5692 else if (fsym->ts.type == BT_CLASS)
5695 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5696 tmp = gfc_get_symbol_decl (vtab);
5697 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5698 ptr = gfc_class_vptr_get (parmse.expr);
5699 gfc_add_modify (&block, ptr,
5700 fold_convert (TREE_TYPE (ptr), tmp));
5701 gfc_add_expr_to_block (&block, tmp);
5704 if (fsym->attr.optional
5705 && e->expr_type == EXPR_VARIABLE
5706 && e->symtree->n.sym->attr.optional)
5708 tmp = fold_build3_loc (input_location, COND_EXPR,
5710 gfc_conv_expr_present (e->symtree->n.sym),
5711 gfc_finish_block (&block),
5712 build_empty_stmt (input_location));
5715 tmp = gfc_finish_block (&block);
5717 gfc_add_expr_to_block (&se->pre, tmp);
5720 if (fsym && (fsym->ts.type == BT_DERIVED
5721 || fsym->ts.type == BT_ASSUMED)
5722 && e->ts.type == BT_CLASS
5723 && !CLASS_DATA (e)->attr.dimension
5724 && !CLASS_DATA (e)->attr.codimension)
5726 parmse.expr = gfc_class_data_get (parmse.expr);
5727 /* The result is a class temporary, whose _data component
5728 must be freed to avoid a memory leak. */
5729 if (e->expr_type == EXPR_FUNCTION
5730 && CLASS_DATA (e)->attr.allocatable)
5736 /* Borrow the function symbol to make a call to
5737 gfc_add_finalizer_call and then restore it. */
5738 tmp = e->symtree->n.sym->backend_decl;
5739 e->symtree->n.sym->backend_decl
5740 = TREE_OPERAND (parmse.expr, 0);
5741 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5742 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5743 finalized = gfc_add_finalizer_call (&parmse.post,
5745 gfc_free_expr (var);
5746 e->symtree->n.sym->backend_decl = tmp;
5747 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5749 /* Then free the class _data. */
5750 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5751 tmp = fold_build2_loc (input_location, NE_EXPR,
5754 tmp = build3_v (COND_EXPR, tmp,
5755 gfc_call_free (parmse.expr),
5756 build_empty_stmt (input_location));
5757 gfc_add_expr_to_block (&parmse.post, tmp);
5758 gfc_add_modify (&parmse.post, parmse.expr, zero);
5762 /* Wrap scalar variable in a descriptor. We need to convert
5763 the address of a pointer back to the pointer itself before,
5764 we can assign it to the data field. */
5766 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5767 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5770 if (TREE_CODE (tmp) == ADDR_EXPR)
5771 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5772 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5774 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5777 else if (fsym && e->expr_type != EXPR_NULL
5778 && ((fsym->attr.pointer
5779 && fsym->attr.flavor != FL_PROCEDURE)
5780 || (fsym->attr.proc_pointer
5781 && !(e->expr_type == EXPR_VARIABLE
5782 && e->symtree->n.sym->attr.dummy))
5783 || (fsym->attr.proc_pointer
5784 && e->expr_type == EXPR_VARIABLE
5785 && gfc_is_proc_ptr_comp (e))
5786 || (fsym->attr.allocatable
5787 && fsym->attr.flavor != FL_PROCEDURE)))
5789 /* Scalar pointer dummy args require an extra level of
5790 indirection. The null pointer already contains
5791 this level of indirection. */
5792 parm_kind = SCALAR_POINTER;
5793 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5797 else if (e->ts.type == BT_CLASS
5798 && fsym && fsym->ts.type == BT_CLASS
5799 && (CLASS_DATA (fsym)->attr.dimension
5800 || CLASS_DATA (fsym)->attr.codimension))
5802 /* Pass a class array. */
5803 parmse.use_offset = 1;
5804 gfc_conv_expr_descriptor (&parmse, e);
5806 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5807 allocated on entry, it must be deallocated. */
5808 if (fsym->attr.intent == INTENT_OUT
5809 && CLASS_DATA (fsym)->attr.allocatable)
5814 gfc_init_block (&block);
5816 ptr = gfc_class_data_get (ptr);
5818 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5819 NULL_TREE, NULL_TREE,
5821 GFC_CAF_COARRAY_NOCOARRAY);
5822 gfc_add_expr_to_block (&block, tmp);
5823 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5824 void_type_node, ptr,
5826 gfc_add_expr_to_block (&block, tmp);
5827 gfc_reset_vptr (&block, e);
5829 if (fsym->attr.optional
5830 && e->expr_type == EXPR_VARIABLE
5832 || (e->ref->type == REF_ARRAY
5833 && e->ref->u.ar.type != AR_FULL))
5834 && e->symtree->n.sym->attr.optional)
5836 tmp = fold_build3_loc (input_location, COND_EXPR,
5838 gfc_conv_expr_present (e->symtree->n.sym),
5839 gfc_finish_block (&block),
5840 build_empty_stmt (input_location));
5843 tmp = gfc_finish_block (&block);
5845 gfc_add_expr_to_block (&se->pre, tmp);
5848 /* The conversion does not repackage the reference to a class
5849 array - _data descriptor. */
5850 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5851 fsym->attr.intent != INTENT_IN
5852 && (CLASS_DATA (fsym)->attr.class_pointer
5853 || CLASS_DATA (fsym)->attr.allocatable),
5855 && e->expr_type == EXPR_VARIABLE
5856 && e->symtree->n.sym->attr.optional,
5857 CLASS_DATA (fsym)->attr.class_pointer
5858 || CLASS_DATA (fsym)->attr.allocatable);
5862 /* If the argument is a function call that may not create
5863 a temporary for the result, we have to check that we
5864 can do it, i.e. that there is no alias between this
5865 argument and another one. */
5866 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5872 intent = fsym->attr.intent;
5874 intent = INTENT_UNKNOWN;
5876 if (gfc_check_fncall_dependency (e, intent, sym, args,
5878 parmse.force_tmp = 1;
5880 iarg = e->value.function.actual->expr;
5882 /* Temporary needed if aliasing due to host association. */
5883 if (sym->attr.contained
5885 && !sym->attr.implicit_pure
5886 && !sym->attr.use_assoc
5887 && iarg->expr_type == EXPR_VARIABLE
5888 && sym->ns == iarg->symtree->n.sym->ns)
5889 parmse.force_tmp = 1;
5891 /* Ditto within module. */
5892 if (sym->attr.use_assoc
5894 && !sym->attr.implicit_pure
5895 && iarg->expr_type == EXPR_VARIABLE
5896 && sym->module == iarg->symtree->n.sym->module)
5897 parmse.force_tmp = 1;
5900 if (sym->attr.is_bind_c && e
5901 && fsym && fsym->attr.dimension
5902 && (fsym->attr.pointer
5903 || fsym->attr.allocatable
5904 || fsym->as->type == AS_ASSUMED_RANK
5905 || fsym->as->type == AS_ASSUMED_SHAPE
5906 || non_unity_length_string))
5907 /* Implement F2018, C.12.6.1: paragraph (2). */
5908 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5910 else if (e->expr_type == EXPR_VARIABLE
5911 && is_subref_array (e)
5912 && !(fsym && fsym->attr.pointer))
5913 /* The actual argument is a component reference to an
5914 array of derived types. In this case, the argument
5915 is converted to a temporary, which is passed and then
5916 written back after the procedure call. */
5917 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5918 fsym ? fsym->attr.intent : INTENT_INOUT,
5919 fsym && fsym->attr.pointer);
5921 else if (gfc_is_class_array_ref (e, NULL)
5922 && fsym && fsym->ts.type == BT_DERIVED)
5923 /* The actual argument is a component reference to an
5924 array of derived types. In this case, the argument
5925 is converted to a temporary, which is passed and then
5926 written back after the procedure call.
5927 OOP-TODO: Insert code so that if the dynamic type is
5928 the same as the declared type, copy-in/copy-out does
5930 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5931 fsym ? fsym->attr.intent : INTENT_INOUT,
5932 fsym && fsym->attr.pointer);
5934 else if (gfc_is_class_array_function (e)
5935 && fsym && fsym->ts.type == BT_DERIVED)
5936 /* See previous comment. For function actual argument,
5937 the write out is not needed so the intent is set as
5940 e->must_finalize = 1;
5941 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5943 fsym && fsym->attr.pointer);
5945 else if (fsym && fsym->attr.contiguous
5946 && !gfc_is_simply_contiguous (e, false, true))
5948 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5949 fsym ? fsym->attr.intent : INTENT_INOUT,
5950 fsym && fsym->attr.pointer);
5953 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5956 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5957 allocated on entry, it must be deallocated. */
5958 if (fsym && fsym->attr.allocatable
5959 && fsym->attr.intent == INTENT_OUT)
5961 if (fsym->ts.type == BT_DERIVED
5962 && fsym->ts.u.derived->attr.alloc_comp)
5964 // deallocate the components first
5965 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5966 parmse.expr, e->rank);
5967 if (tmp != NULL_TREE)
5968 gfc_add_expr_to_block (&se->pre, tmp);
5971 tmp = build_fold_indirect_ref_loc (input_location,
5973 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5974 tmp = gfc_conv_descriptor_data_get (tmp);
5975 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5976 NULL_TREE, NULL_TREE, true,
5978 GFC_CAF_COARRAY_NOCOARRAY);
5979 if (fsym->attr.optional
5980 && e->expr_type == EXPR_VARIABLE
5981 && e->symtree->n.sym->attr.optional)
5982 tmp = fold_build3_loc (input_location, COND_EXPR,
5984 gfc_conv_expr_present (e->symtree->n.sym),
5985 tmp, build_empty_stmt (input_location));
5986 gfc_add_expr_to_block (&se->pre, tmp);
5991 /* The case with fsym->attr.optional is that of a user subroutine
5992 with an interface indicating an optional argument. When we call
5993 an intrinsic subroutine, however, fsym is NULL, but we might still
5994 have an optional argument, so we proceed to the substitution
5996 if (e && (fsym == NULL || fsym->attr.optional))
5998 /* If an optional argument is itself an optional dummy argument,
5999 check its presence and substitute a null if absent. This is
6000 only needed when passing an array to an elemental procedure
6001 as then array elements are accessed - or no NULL pointer is
6002 allowed and a "1" or "0" should be passed if not present.
6003 When passing a non-array-descriptor full array to a
6004 non-array-descriptor dummy, no check is needed. For
6005 array-descriptor actual to array-descriptor dummy, see
6006 PR 41911 for why a check has to be inserted.
6007 fsym == NULL is checked as intrinsics required the descriptor
6008 but do not always set fsym.
6009 Also, it is necessary to pass a NULL pointer to library routines
6010 which usually ignore optional arguments, so they can handle
6011 these themselves. */
6012 if (e->expr_type == EXPR_VARIABLE
6013 && e->symtree->n.sym->attr.optional
6014 && (((e->rank != 0 && elemental_proc)
6015 || e->representation.length || e->ts.type == BT_CHARACTER
6019 && (fsym->as->type == AS_ASSUMED_SHAPE
6020 || fsym->as->type == AS_ASSUMED_RANK
6021 || fsym->as->type == AS_DEFERRED)))))
6022 || se->ignore_optional))
6023 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6024 e->representation.length);
6029 /* Obtain the character length of an assumed character length
6030 length procedure from the typespec. */
6031 if (fsym->ts.type == BT_CHARACTER
6032 && parmse.string_length == NULL_TREE
6033 && e->ts.type == BT_PROCEDURE
6034 && e->symtree->n.sym->ts.type == BT_CHARACTER
6035 && e->symtree->n.sym->ts.u.cl->length != NULL
6036 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6038 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6039 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6043 if (fsym && need_interface_mapping && e)
6044 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6046 gfc_add_block_to_block (&se->pre, &parmse.pre);
6047 gfc_add_block_to_block (&post, &parmse.post);
6049 /* Allocated allocatable components of derived types must be
6050 deallocated for non-variable scalars, array arguments to elemental
6051 procedures, and array arguments with descriptor to non-elemental
6052 procedures. As bounds information for descriptorless arrays is no
6053 longer available here, they are dealt with in trans-array.c
6054 (gfc_conv_array_parameter). */
6055 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6056 && e->ts.u.derived->attr.alloc_comp
6057 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6058 && !expr_may_alias_variables (e, elemental_proc))
6061 /* It is known the e returns a structure type with at least one
6062 allocatable component. When e is a function, ensure that the
6063 function is called once only by using a temporary variable. */
6064 if (!DECL_P (parmse.expr))
6065 parmse.expr = gfc_evaluate_now_loc (input_location,
6066 parmse.expr, &se->pre);
6068 if (fsym && fsym->attr.value)
6071 tmp = build_fold_indirect_ref_loc (input_location,
6074 parm_rank = e->rank;
6082 case (SCALAR_POINTER):
6083 tmp = build_fold_indirect_ref_loc (input_location,
6088 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6090 /* The derived type is passed to gfc_deallocate_alloc_comp.
6091 Therefore, class actuals can be handled correctly but derived
6092 types passed to class formals need the _data component. */
6093 tmp = gfc_class_data_get (tmp);
6094 if (!CLASS_DATA (fsym)->attr.dimension)
6095 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6098 if (e->expr_type == EXPR_OP
6099 && e->value.op.op == INTRINSIC_PARENTHESES
6100 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6103 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6104 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6106 gfc_add_expr_to_block (&se->post, local_tmp);
6109 if (!finalized && !e->must_finalize)
6111 if ((e->ts.type == BT_CLASS
6112 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6113 || e->ts.type == BT_DERIVED)
6114 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6116 else if (e->ts.type == BT_CLASS)
6117 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6119 gfc_prepend_expr_to_block (&post, tmp);
6123 /* Add argument checking of passing an unallocated/NULL actual to
6124 a nonallocatable/nonpointer dummy. */
6126 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6128 symbol_attribute attr;
6132 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6133 attr = gfc_expr_attr (e);
6135 goto end_pointer_check;
6137 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6138 allocatable to an optional dummy, cf. 12.5.2.12. */
6139 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6140 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6141 goto end_pointer_check;
6145 /* If the actual argument is an optional pointer/allocatable and
6146 the formal argument takes an nonpointer optional value,
6147 it is invalid to pass a non-present argument on, even
6148 though there is no technical reason for this in gfortran.
6149 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6150 tree present, null_ptr, type;
6152 if (attr.allocatable
6153 && (fsym == NULL || !fsym->attr.allocatable))
6154 msg = xasprintf ("Allocatable actual argument '%s' is not "
6155 "allocated or not present",
6156 e->symtree->n.sym->name);
6157 else if (attr.pointer
6158 && (fsym == NULL || !fsym->attr.pointer))
6159 msg = xasprintf ("Pointer actual argument '%s' is not "
6160 "associated or not present",
6161 e->symtree->n.sym->name);
6162 else if (attr.proc_pointer
6163 && (fsym == NULL || !fsym->attr.proc_pointer))
6164 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6165 "associated or not present",
6166 e->symtree->n.sym->name);
6168 goto end_pointer_check;
6170 present = gfc_conv_expr_present (e->symtree->n.sym);
6171 type = TREE_TYPE (present);
6172 present = fold_build2_loc (input_location, EQ_EXPR,
6173 logical_type_node, present,
6175 null_pointer_node));
6176 type = TREE_TYPE (parmse.expr);
6177 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6178 logical_type_node, parmse.expr,
6180 null_pointer_node));
6181 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6182 logical_type_node, present, null_ptr);
6186 if (attr.allocatable
6187 && (fsym == NULL || !fsym->attr.allocatable))
6188 msg = xasprintf ("Allocatable actual argument '%s' is not "
6189 "allocated", e->symtree->n.sym->name);
6190 else if (attr.pointer
6191 && (fsym == NULL || !fsym->attr.pointer))
6192 msg = xasprintf ("Pointer actual argument '%s' is not "
6193 "associated", e->symtree->n.sym->name);
6194 else if (attr.proc_pointer
6195 && (fsym == NULL || !fsym->attr.proc_pointer))
6196 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6197 "associated", e->symtree->n.sym->name);
6199 goto end_pointer_check;
6203 /* If the argument is passed by value, we need to strip the
6205 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6206 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6208 cond = fold_build2_loc (input_location, EQ_EXPR,
6209 logical_type_node, tmp,
6210 fold_convert (TREE_TYPE (tmp),
6211 null_pointer_node));
6214 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6220 /* Deferred length dummies pass the character length by reference
6221 so that the value can be returned. */
6222 if (parmse.string_length && fsym && fsym->ts.deferred)
6224 if (INDIRECT_REF_P (parmse.string_length))
6225 /* In chains of functions/procedure calls the string_length already
6226 is a pointer to the variable holding the length. Therefore
6227 remove the deref on call. */
6228 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6231 tmp = parmse.string_length;
6232 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6233 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6234 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6238 /* Character strings are passed as two parameters, a length and a
6239 pointer - except for Bind(c) which only passes the pointer.
6240 An unlimited polymorphic formal argument likewise does not
6242 if (parmse.string_length != NULL_TREE
6243 && !sym->attr.is_bind_c
6244 && !(fsym && UNLIMITED_POLY (fsym)))
6245 vec_safe_push (stringargs, parmse.string_length);
6247 /* When calling __copy for character expressions to unlimited
6248 polymorphic entities, the dst argument needs a string length. */
6249 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6250 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6251 && arg->next && arg->next->expr
6252 && (arg->next->expr->ts.type == BT_DERIVED
6253 || arg->next->expr->ts.type == BT_CLASS)
6254 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6255 vec_safe_push (stringargs, parmse.string_length);
6257 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6258 pass the token and the offset as additional arguments. */
6259 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6260 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6261 && !fsym->attr.allocatable)
6262 || (fsym->ts.type == BT_CLASS
6263 && CLASS_DATA (fsym)->attr.codimension
6264 && !CLASS_DATA (fsym)->attr.allocatable)))
6266 /* Token and offset. */
6267 vec_safe_push (stringargs, null_pointer_node);
6268 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6269 gcc_assert (fsym->attr.optional);
6271 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6272 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6273 && !fsym->attr.allocatable)
6274 || (fsym->ts.type == BT_CLASS
6275 && CLASS_DATA (fsym)->attr.codimension
6276 && !CLASS_DATA (fsym)->attr.allocatable)))
6278 tree caf_decl, caf_type;
6281 caf_decl = gfc_get_tree_for_caf_expr (e);
6282 caf_type = TREE_TYPE (caf_decl);
6284 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6285 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6286 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6287 tmp = gfc_conv_descriptor_token (caf_decl);
6288 else if (DECL_LANG_SPECIFIC (caf_decl)
6289 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6290 tmp = GFC_DECL_TOKEN (caf_decl);
6293 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6294 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6295 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6298 vec_safe_push (stringargs, tmp);
6300 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6301 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6302 offset = build_int_cst (gfc_array_index_type, 0);
6303 else if (DECL_LANG_SPECIFIC (caf_decl)
6304 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6305 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6306 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6307 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6309 offset = build_int_cst (gfc_array_index_type, 0);
6311 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6312 tmp = gfc_conv_descriptor_data_get (caf_decl);
6315 gcc_assert (POINTER_TYPE_P (caf_type));
6319 tmp2 = fsym->ts.type == BT_CLASS
6320 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6321 if ((fsym->ts.type != BT_CLASS
6322 && (fsym->as->type == AS_ASSUMED_SHAPE
6323 || fsym->as->type == AS_ASSUMED_RANK))
6324 || (fsym->ts.type == BT_CLASS
6325 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6326 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6328 if (fsym->ts.type == BT_CLASS)
6329 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6332 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6333 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6335 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6336 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6338 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6339 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6342 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6345 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6346 gfc_array_index_type,
6347 fold_convert (gfc_array_index_type, tmp2),
6348 fold_convert (gfc_array_index_type, tmp));
6349 offset = fold_build2_loc (input_location, PLUS_EXPR,
6350 gfc_array_index_type, offset, tmp);
6352 vec_safe_push (stringargs, offset);
6355 vec_safe_push (arglist, parmse.expr);
6357 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6361 else if (sym->ts.type == BT_CLASS)
6362 ts = CLASS_DATA (sym)->ts;
6366 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6367 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6368 else if (ts.type == BT_CHARACTER)
6370 if (ts.u.cl->length == NULL)
6372 /* Assumed character length results are not allowed by C418 of the 2003
6373 standard and are trapped in resolve.c; except in the case of SPREAD
6374 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6375 we take the character length of the first argument for the result.
6376 For dummies, we have to look through the formal argument list for
6377 this function and use the character length found there.*/
6379 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6380 else if (!sym->attr.dummy)
6381 cl.backend_decl = (*stringargs)[0];
6384 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6385 for (; formal; formal = formal->next)
6386 if (strcmp (formal->sym->name, sym->name) == 0)
6387 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6389 len = cl.backend_decl;
6395 /* Calculate the length of the returned string. */
6396 gfc_init_se (&parmse, NULL);
6397 if (need_interface_mapping)
6398 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6400 gfc_conv_expr (&parmse, ts.u.cl->length);
6401 gfc_add_block_to_block (&se->pre, &parmse.pre);
6402 gfc_add_block_to_block (&se->post, &parmse.post);
6404 /* TODO: It would be better to have the charlens as
6405 gfc_charlen_type_node already when the interface is
6406 created instead of converting it here (see PR 84615). */
6407 tmp = fold_build2_loc (input_location, MAX_EXPR,
6408 gfc_charlen_type_node,
6409 fold_convert (gfc_charlen_type_node, tmp),
6410 build_zero_cst (gfc_charlen_type_node));
6411 cl.backend_decl = tmp;
6414 /* Set up a charlen structure for it. */
6419 len = cl.backend_decl;
6422 byref = (comp && (comp->attr.dimension
6423 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6424 || (!comp && gfc_return_by_reference (sym));
6427 if (se->direct_byref)
6429 /* Sometimes, too much indirection can be applied; e.g. for
6430 function_result = array_valued_recursive_function. */
6431 if (TREE_TYPE (TREE_TYPE (se->expr))
6432 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6433 && GFC_DESCRIPTOR_TYPE_P
6434 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6435 se->expr = build_fold_indirect_ref_loc (input_location,
6438 /* If the lhs of an assignment x = f(..) is allocatable and
6439 f2003 is allowed, we must do the automatic reallocation.
6440 TODO - deal with intrinsics, without using a temporary. */
6441 if (flag_realloc_lhs
6442 && se->ss && se->ss->loop_chain
6443 && se->ss->loop_chain->is_alloc_lhs
6444 && !expr->value.function.isym
6445 && sym->result->as != NULL)
6447 /* Evaluate the bounds of the result, if known. */
6448 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6451 /* Perform the automatic reallocation. */
6452 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6454 gfc_add_expr_to_block (&se->pre, tmp);
6456 /* Pass the temporary as the first argument. */
6457 result = info->descriptor;
6460 result = build_fold_indirect_ref_loc (input_location,
6462 vec_safe_push (retargs, se->expr);
6464 else if (comp && comp->attr.dimension)
6466 gcc_assert (se->loop && info);
6468 /* Set the type of the array. */
6469 tmp = gfc_typenode_for_spec (&comp->ts);
6470 gcc_assert (se->ss->dimen == se->loop->dimen);
6472 /* Evaluate the bounds of the result, if known. */
6473 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6475 /* If the lhs of an assignment x = f(..) is allocatable and
6476 f2003 is allowed, we must not generate the function call
6477 here but should just send back the results of the mapping.
6478 This is signalled by the function ss being flagged. */
6479 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6481 gfc_free_interface_mapping (&mapping);
6482 return has_alternate_specifier;
6485 /* Create a temporary to store the result. In case the function
6486 returns a pointer, the temporary will be a shallow copy and
6487 mustn't be deallocated. */
6488 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6489 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6490 tmp, NULL_TREE, false,
6491 !comp->attr.pointer, callee_alloc,
6492 &se->ss->info->expr->where);
6494 /* Pass the temporary as the first argument. */
6495 result = info->descriptor;
6496 tmp = gfc_build_addr_expr (NULL_TREE, result);
6497 vec_safe_push (retargs, tmp);
6499 else if (!comp && sym->result->attr.dimension)
6501 gcc_assert (se->loop && info);
6503 /* Set the type of the array. */
6504 tmp = gfc_typenode_for_spec (&ts);
6505 gcc_assert (se->ss->dimen == se->loop->dimen);
6507 /* Evaluate the bounds of the result, if known. */
6508 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6510 /* If the lhs of an assignment x = f(..) is allocatable and
6511 f2003 is allowed, we must not generate the function call
6512 here but should just send back the results of the mapping.
6513 This is signalled by the function ss being flagged. */
6514 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6516 gfc_free_interface_mapping (&mapping);
6517 return has_alternate_specifier;
6520 /* Create a temporary to store the result. In case the function
6521 returns a pointer, the temporary will be a shallow copy and
6522 mustn't be deallocated. */
6523 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6524 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6525 tmp, NULL_TREE, false,
6526 !sym->attr.pointer, callee_alloc,
6527 &se->ss->info->expr->where);
6529 /* Pass the temporary as the first argument. */
6530 result = info->descriptor;
6531 tmp = gfc_build_addr_expr (NULL_TREE, result);
6532 vec_safe_push (retargs, tmp);
6534 else if (ts.type == BT_CHARACTER)
6536 /* Pass the string length. */
6537 type = gfc_get_character_type (ts.kind, ts.u.cl);
6538 type = build_pointer_type (type);
6540 /* Emit a DECL_EXPR for the VLA type. */
6541 tmp = TREE_TYPE (type);
6543 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6545 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6546 DECL_ARTIFICIAL (tmp) = 1;
6547 DECL_IGNORED_P (tmp) = 1;
6548 tmp = fold_build1_loc (input_location, DECL_EXPR,
6549 TREE_TYPE (tmp), tmp);
6550 gfc_add_expr_to_block (&se->pre, tmp);
6553 /* Return an address to a char[0:len-1]* temporary for
6554 character pointers. */
6555 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6556 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6558 var = gfc_create_var (type, "pstr");
6560 if ((!comp && sym->attr.allocatable)
6561 || (comp && comp->attr.allocatable))
6563 gfc_add_modify (&se->pre, var,
6564 fold_convert (TREE_TYPE (var),
6565 null_pointer_node));
6566 tmp = gfc_call_free (var);
6567 gfc_add_expr_to_block (&se->post, tmp);
6570 /* Provide an address expression for the function arguments. */
6571 var = gfc_build_addr_expr (NULL_TREE, var);
6574 var = gfc_conv_string_tmp (se, type, len);
6576 vec_safe_push (retargs, var);
6580 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6582 type = gfc_get_complex_type (ts.kind);
6583 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6584 vec_safe_push (retargs, var);
6587 /* Add the string length to the argument list. */
6588 if (ts.type == BT_CHARACTER && ts.deferred)
6592 tmp = gfc_evaluate_now (len, &se->pre);
6593 TREE_STATIC (tmp) = 1;
6594 gfc_add_modify (&se->pre, tmp,
6595 build_int_cst (TREE_TYPE (tmp), 0));
6596 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6597 vec_safe_push (retargs, tmp);
6599 else if (ts.type == BT_CHARACTER)
6600 vec_safe_push (retargs, len);
6602 gfc_free_interface_mapping (&mapping);
6604 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6605 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6606 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6607 vec_safe_reserve (retargs, arglen);
6609 /* Add the return arguments. */
6610 vec_safe_splice (retargs, arglist);
6612 /* Add the hidden present status for optional+value to the arguments. */
6613 vec_safe_splice (retargs, optionalargs);
6615 /* Add the hidden string length parameters to the arguments. */
6616 vec_safe_splice (retargs, stringargs);
6618 /* We may want to append extra arguments here. This is used e.g. for
6619 calls to libgfortran_matmul_??, which need extra information. */
6620 vec_safe_splice (retargs, append_args);
6624 /* Generate the actual call. */
6625 if (base_object == NULL_TREE)
6626 conv_function_val (se, sym, expr, args);
6628 conv_base_obj_fcn_val (se, base_object, expr);
6630 /* If there are alternate return labels, function type should be
6631 integer. Can't modify the type in place though, since it can be shared
6632 with other functions. For dummy arguments, the typing is done to
6633 this result, even if it has to be repeated for each call. */
6634 if (has_alternate_specifier
6635 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6637 if (!sym->attr.dummy)
6639 TREE_TYPE (sym->backend_decl)
6640 = build_function_type (integer_type_node,
6641 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6642 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6645 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6648 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6649 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6651 /* Allocatable scalar function results must be freed and nullified
6652 after use. This necessitates the creation of a temporary to
6653 hold the result to prevent duplicate calls. */
6654 if (!byref && sym->ts.type != BT_CHARACTER
6655 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6656 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6658 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6659 gfc_add_modify (&se->pre, tmp, se->expr);
6661 tmp = gfc_call_free (tmp);
6662 gfc_add_expr_to_block (&post, tmp);
6663 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6666 /* If we have a pointer function, but we don't want a pointer, e.g.
6669 where f is pointer valued, we have to dereference the result. */
6670 if (!se->want_pointer && !byref
6671 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6672 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6673 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6675 /* f2c calling conventions require a scalar default real function to
6676 return a double precision result. Convert this back to default
6677 real. We only care about the cases that can happen in Fortran 77.
6679 if (flag_f2c && sym->ts.type == BT_REAL
6680 && sym->ts.kind == gfc_default_real_kind
6681 && !sym->attr.always_explicit)
6682 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6684 /* A pure function may still have side-effects - it may modify its
6686 TREE_SIDE_EFFECTS (se->expr) = 1;
6688 if (!sym->attr.pure)
6689 TREE_SIDE_EFFECTS (se->expr) = 1;
6694 /* Add the function call to the pre chain. There is no expression. */
6695 gfc_add_expr_to_block (&se->pre, se->expr);
6696 se->expr = NULL_TREE;
6698 if (!se->direct_byref)
6700 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6702 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6704 /* Check the data pointer hasn't been modified. This would
6705 happen in a function returning a pointer. */
6706 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6707 tmp = fold_build2_loc (input_location, NE_EXPR,
6710 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6713 se->expr = info->descriptor;
6714 /* Bundle in the string length. */
6715 se->string_length = len;
6717 else if (ts.type == BT_CHARACTER)
6719 /* Dereference for character pointer results. */
6720 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6721 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6722 se->expr = build_fold_indirect_ref_loc (input_location, var);
6726 se->string_length = len;
6730 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6731 se->expr = build_fold_indirect_ref_loc (input_location, var);
6736 /* Associate the rhs class object's meta-data with the result, when the
6737 result is a temporary. */
6738 if (args && args->expr && args->expr->ts.type == BT_CLASS
6739 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6740 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6743 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6745 gfc_init_se (&parmse, NULL);
6746 parmse.data_not_needed = 1;
6747 gfc_conv_expr (&parmse, class_expr);
6748 if (!DECL_LANG_SPECIFIC (result))
6749 gfc_allocate_lang_decl (result);
6750 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6751 gfc_free_expr (class_expr);
6752 gcc_assert (parmse.pre.head == NULL_TREE
6753 && parmse.post.head == NULL_TREE);
6756 /* Follow the function call with the argument post block. */
6759 gfc_add_block_to_block (&se->pre, &post);
6761 /* Transformational functions of derived types with allocatable
6762 components must have the result allocatable components copied when the
6763 argument is actually given. */
6764 arg = expr->value.function.actual;
6765 if (result && arg && expr->rank
6766 && expr->value.function.isym
6767 && expr->value.function.isym->transformational
6769 && arg->expr->ts.type == BT_DERIVED
6770 && arg->expr->ts.u.derived->attr.alloc_comp)
6773 /* Copy the allocatable components. We have to use a
6774 temporary here to prevent source allocatable components
6775 from being corrupted. */
6776 tmp2 = gfc_evaluate_now (result, &se->pre);
6777 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6778 result, tmp2, expr->rank, 0);
6779 gfc_add_expr_to_block (&se->pre, tmp);
6780 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6782 gfc_add_expr_to_block (&se->pre, tmp);
6784 /* Finally free the temporary's data field. */
6785 tmp = gfc_conv_descriptor_data_get (tmp2);
6786 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6787 NULL_TREE, NULL_TREE, true,
6788 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6789 gfc_add_expr_to_block (&se->pre, tmp);
6794 /* For a function with a class array result, save the result as
6795 a temporary, set the info fields needed by the scalarizer and
6796 call the finalization function of the temporary. Note that the
6797 nullification of allocatable components needed by the result
6798 is done in gfc_trans_assignment_1. */
6799 if (expr && ((gfc_is_class_array_function (expr)
6800 && se->ss && se->ss->loop)
6801 || gfc_is_alloc_class_scalar_function (expr))
6802 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6803 && expr->must_finalize)
6808 if (se->ss && se->ss->loop)
6810 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6811 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6812 tmp = gfc_class_data_get (se->expr);
6813 info->descriptor = tmp;
6814 info->data = gfc_conv_descriptor_data_get (tmp);
6815 info->offset = gfc_conv_descriptor_offset_get (tmp);
6816 for (n = 0; n < se->ss->loop->dimen; n++)
6818 tree dim = gfc_rank_cst[n];
6819 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6820 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6825 /* TODO Eliminate the doubling of temporaries. This
6826 one is necessary to ensure no memory leakage. */
6827 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6828 tmp = gfc_class_data_get (se->expr);
6829 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6830 CLASS_DATA (expr->value.function.esym->result)->attr);
6833 if ((gfc_is_class_array_function (expr)
6834 || gfc_is_alloc_class_scalar_function (expr))
6835 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6836 goto no_finalization;
6838 final_fndecl = gfc_class_vtab_final_get (se->expr);
6839 is_final = fold_build2_loc (input_location, NE_EXPR,
6842 fold_convert (TREE_TYPE (final_fndecl),
6843 null_pointer_node));
6844 final_fndecl = build_fold_indirect_ref_loc (input_location,
6846 tmp = build_call_expr_loc (input_location,
6848 gfc_build_addr_expr (NULL, tmp),
6849 gfc_class_vtab_size_get (se->expr),
6850 boolean_false_node);
6851 tmp = fold_build3_loc (input_location, COND_EXPR,
6852 void_type_node, is_final, tmp,
6853 build_empty_stmt (input_location));
6855 if (se->ss && se->ss->loop)
6857 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6858 tmp = fold_build2_loc (input_location, NE_EXPR,
6861 fold_convert (TREE_TYPE (info->data),
6862 null_pointer_node));
6863 tmp = fold_build3_loc (input_location, COND_EXPR,
6864 void_type_node, tmp,
6865 gfc_call_free (info->data),
6866 build_empty_stmt (input_location));
6867 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6872 gfc_prepend_expr_to_block (&se->post, tmp);
6873 classdata = gfc_class_data_get (se->expr);
6874 tmp = fold_build2_loc (input_location, NE_EXPR,
6877 fold_convert (TREE_TYPE (classdata),
6878 null_pointer_node));
6879 tmp = fold_build3_loc (input_location, COND_EXPR,
6880 void_type_node, tmp,
6881 gfc_call_free (classdata),
6882 build_empty_stmt (input_location));
6883 gfc_add_expr_to_block (&se->post, tmp);
6888 gfc_add_block_to_block (&se->post, &post);
6891 return has_alternate_specifier;
6895 /* Fill a character string with spaces. */
6898 fill_with_spaces (tree start, tree type, tree size)
6900 stmtblock_t block, loop;
6901 tree i, el, exit_label, cond, tmp;
6903 /* For a simple char type, we can call memset(). */
6904 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6905 return build_call_expr_loc (input_location,
6906 builtin_decl_explicit (BUILT_IN_MEMSET),
6908 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6909 lang_hooks.to_target_charset (' ')),
6910 fold_convert (size_type_node, size));
6912 /* Otherwise, we use a loop:
6913 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6917 /* Initialize variables. */
6918 gfc_init_block (&block);
6919 i = gfc_create_var (sizetype, "i");
6920 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6921 el = gfc_create_var (build_pointer_type (type), "el");
6922 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6923 exit_label = gfc_build_label_decl (NULL_TREE);
6924 TREE_USED (exit_label) = 1;
6928 gfc_init_block (&loop);
6930 /* Exit condition. */
6931 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6932 build_zero_cst (sizetype));
6933 tmp = build1_v (GOTO_EXPR, exit_label);
6934 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6935 build_empty_stmt (input_location));
6936 gfc_add_expr_to_block (&loop, tmp);
6939 gfc_add_modify (&loop,
6940 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6941 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6943 /* Increment loop variables. */
6944 gfc_add_modify (&loop, i,
6945 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6946 TYPE_SIZE_UNIT (type)));
6947 gfc_add_modify (&loop, el,
6948 fold_build_pointer_plus_loc (input_location,
6949 el, TYPE_SIZE_UNIT (type)));
6951 /* Making the loop... actually loop! */
6952 tmp = gfc_finish_block (&loop);
6953 tmp = build1_v (LOOP_EXPR, tmp);
6954 gfc_add_expr_to_block (&block, tmp);
6956 /* The exit label. */
6957 tmp = build1_v (LABEL_EXPR, exit_label);
6958 gfc_add_expr_to_block (&block, tmp);
6961 return gfc_finish_block (&block);
6965 /* Generate code to copy a string. */
6968 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6969 int dkind, tree slength, tree src, int skind)
6971 tree tmp, dlen, slen;
6980 stmtblock_t tempblock;
6982 gcc_assert (dkind == skind);
6984 if (slength != NULL_TREE)
6986 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6987 ssc = gfc_string_to_single_character (slen, src, skind);
6991 slen = build_one_cst (gfc_charlen_type_node);
6995 if (dlength != NULL_TREE)
6997 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6998 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7002 dlen = build_one_cst (gfc_charlen_type_node);
7006 /* Assign directly if the types are compatible. */
7007 if (dsc != NULL_TREE && ssc != NULL_TREE
7008 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7010 gfc_add_modify (block, dsc, ssc);
7014 /* The string copy algorithm below generates code like
7018 if (srclen < destlen)
7020 memmove (dest, src, srclen);
7022 memset (&dest[srclen], ' ', destlen - srclen);
7026 // Truncate if too long.
7027 memmove (dest, src, destlen);
7032 /* Do nothing if the destination length is zero. */
7033 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7034 build_zero_cst (TREE_TYPE (dlen)));
7036 /* For non-default character kinds, we have to multiply the string
7037 length by the base type size. */
7038 chartype = gfc_get_char_type (dkind);
7039 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7041 fold_convert (TREE_TYPE (slen),
7042 TYPE_SIZE_UNIT (chartype)));
7043 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7045 fold_convert (TREE_TYPE (dlen),
7046 TYPE_SIZE_UNIT (chartype)));
7048 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7049 dest = fold_convert (pvoid_type_node, dest);
7051 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7053 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7054 src = fold_convert (pvoid_type_node, src);
7056 src = gfc_build_addr_expr (pvoid_type_node, src);
7058 /* Truncate string if source is too long. */
7059 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7062 /* Copy and pad with spaces. */
7063 tmp3 = build_call_expr_loc (input_location,
7064 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7066 fold_convert (size_type_node, slen));
7068 /* Wstringop-overflow appears at -O3 even though this warning is not
7069 explicitly available in fortran nor can it be switched off. If the
7070 source length is a constant, its negative appears as a very large
7071 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7072 the result of the MINUS_EXPR suppresses this spurious warning. */
7073 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7074 TREE_TYPE(dlen), dlen, slen);
7075 if (slength && TREE_CONSTANT (slength))
7076 tmp = gfc_evaluate_now (tmp, block);
7078 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7079 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7081 gfc_init_block (&tempblock);
7082 gfc_add_expr_to_block (&tempblock, tmp3);
7083 gfc_add_expr_to_block (&tempblock, tmp4);
7084 tmp3 = gfc_finish_block (&tempblock);
7086 /* The truncated memmove if the slen >= dlen. */
7087 tmp2 = build_call_expr_loc (input_location,
7088 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7090 fold_convert (size_type_node, dlen));
7092 /* The whole copy_string function is there. */
7093 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7095 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7096 build_empty_stmt (input_location));
7097 gfc_add_expr_to_block (block, tmp);
7101 /* Translate a statement function.
7102 The value of a statement function reference is obtained by evaluating the
7103 expression using the values of the actual arguments for the values of the
7104 corresponding dummy arguments. */
7107 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7111 gfc_formal_arglist *fargs;
7112 gfc_actual_arglist *args;
7115 gfc_saved_var *saved_vars;
7121 sym = expr->symtree->n.sym;
7122 args = expr->value.function.actual;
7123 gfc_init_se (&lse, NULL);
7124 gfc_init_se (&rse, NULL);
7127 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7129 saved_vars = XCNEWVEC (gfc_saved_var, n);
7130 temp_vars = XCNEWVEC (tree, n);
7132 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7133 fargs = fargs->next, n++)
7135 /* Each dummy shall be specified, explicitly or implicitly, to be
7137 gcc_assert (fargs->sym->attr.dimension == 0);
7140 if (fsym->ts.type == BT_CHARACTER)
7142 /* Copy string arguments. */
7145 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7146 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7148 /* Create a temporary to hold the value. */
7149 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7150 fsym->ts.u.cl->backend_decl
7151 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7153 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7154 temp_vars[n] = gfc_create_var (type, fsym->name);
7156 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7158 gfc_conv_expr (&rse, args->expr);
7159 gfc_conv_string_parameter (&rse);
7160 gfc_add_block_to_block (&se->pre, &lse.pre);
7161 gfc_add_block_to_block (&se->pre, &rse.pre);
7163 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7164 rse.string_length, rse.expr, fsym->ts.kind);
7165 gfc_add_block_to_block (&se->pre, &lse.post);
7166 gfc_add_block_to_block (&se->pre, &rse.post);
7170 /* For everything else, just evaluate the expression. */
7172 /* Create a temporary to hold the value. */
7173 type = gfc_typenode_for_spec (&fsym->ts);
7174 temp_vars[n] = gfc_create_var (type, fsym->name);
7176 gfc_conv_expr (&lse, args->expr);
7178 gfc_add_block_to_block (&se->pre, &lse.pre);
7179 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7180 gfc_add_block_to_block (&se->pre, &lse.post);
7186 /* Use the temporary variables in place of the real ones. */
7187 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7188 fargs = fargs->next, n++)
7189 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7191 gfc_conv_expr (se, sym->value);
7193 if (sym->ts.type == BT_CHARACTER)
7195 gfc_conv_const_charlen (sym->ts.u.cl);
7197 /* Force the expression to the correct length. */
7198 if (!INTEGER_CST_P (se->string_length)
7199 || tree_int_cst_lt (se->string_length,
7200 sym->ts.u.cl->backend_decl))
7202 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7203 tmp = gfc_create_var (type, sym->name);
7204 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7205 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7206 sym->ts.kind, se->string_length, se->expr,
7210 se->string_length = sym->ts.u.cl->backend_decl;
7213 /* Restore the original variables. */
7214 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7215 fargs = fargs->next, n++)
7216 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7222 /* Translate a function expression. */
7225 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7229 if (expr->value.function.isym)
7231 gfc_conv_intrinsic_function (se, expr);
7235 /* expr.value.function.esym is the resolved (specific) function symbol for
7236 most functions. However this isn't set for dummy procedures. */
7237 sym = expr->value.function.esym;
7239 sym = expr->symtree->n.sym;
7241 /* The IEEE_ARITHMETIC functions are caught here. */
7242 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7243 if (gfc_conv_ieee_arithmetic_function (se, expr))
7246 /* We distinguish statement functions from general functions to improve
7247 runtime performance. */
7248 if (sym->attr.proc == PROC_ST_FUNCTION)
7250 gfc_conv_statement_function (se, expr);
7254 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7259 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7262 is_zero_initializer_p (gfc_expr * expr)
7264 if (expr->expr_type != EXPR_CONSTANT)
7267 /* We ignore constants with prescribed memory representations for now. */
7268 if (expr->representation.string)
7271 switch (expr->ts.type)
7274 return mpz_cmp_si (expr->value.integer, 0) == 0;
7277 return mpfr_zero_p (expr->value.real)
7278 && MPFR_SIGN (expr->value.real) >= 0;
7281 return expr->value.logical == 0;
7284 return mpfr_zero_p (mpc_realref (expr->value.complex))
7285 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7286 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7287 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7297 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7302 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7303 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7305 gfc_conv_tmp_array_ref (se);
7309 /* Build a static initializer. EXPR is the expression for the initial value.
7310 The other parameters describe the variable of the component being
7311 initialized. EXPR may be null. */
7314 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7315 bool array, bool pointer, bool procptr)
7319 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7320 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7321 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7322 return build_constructor (type, NULL);
7324 if (!(expr || pointer || procptr))
7327 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7328 (these are the only two iso_c_binding derived types that can be
7329 used as initialization expressions). If so, we need to modify
7330 the 'expr' to be that for a (void *). */
7331 if (expr != NULL && expr->ts.type == BT_DERIVED
7332 && expr->ts.is_iso_c && expr->ts.u.derived)
7334 if (TREE_CODE (type) == ARRAY_TYPE)
7335 return build_constructor (type, NULL);
7336 else if (POINTER_TYPE_P (type))
7337 return build_int_cst (type, 0);
7342 if (array && !procptr)
7345 /* Arrays need special handling. */
7347 ctor = gfc_build_null_descriptor (type);
7348 /* Special case assigning an array to zero. */
7349 else if (is_zero_initializer_p (expr))
7350 ctor = build_constructor (type, NULL);
7352 ctor = gfc_conv_array_initializer (type, expr);
7353 TREE_STATIC (ctor) = 1;
7356 else if (pointer || procptr)
7358 if (ts->type == BT_CLASS && !procptr)
7360 gfc_init_se (&se, NULL);
7361 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7362 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7363 TREE_STATIC (se.expr) = 1;
7366 else if (!expr || expr->expr_type == EXPR_NULL)
7367 return fold_convert (type, null_pointer_node);
7370 gfc_init_se (&se, NULL);
7371 se.want_pointer = 1;
7372 gfc_conv_expr (&se, expr);
7373 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7383 gfc_init_se (&se, NULL);
7384 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7385 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7387 gfc_conv_structure (&se, expr, 1);
7388 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7389 TREE_STATIC (se.expr) = 1;
7394 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7395 TREE_STATIC (ctor) = 1;
7400 gfc_init_se (&se, NULL);
7401 gfc_conv_constant (&se, expr);
7402 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7409 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7415 gfc_array_info *lss_array;
7422 gfc_start_block (&block);
7424 /* Initialize the scalarizer. */
7425 gfc_init_loopinfo (&loop);
7427 gfc_init_se (&lse, NULL);
7428 gfc_init_se (&rse, NULL);
7431 rss = gfc_walk_expr (expr);
7432 if (rss == gfc_ss_terminator)
7433 /* The rhs is scalar. Add a ss for the expression. */
7434 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7436 /* Create a SS for the destination. */
7437 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7439 lss_array = &lss->info->data.array;
7440 lss_array->shape = gfc_get_shape (cm->as->rank);
7441 lss_array->descriptor = dest;
7442 lss_array->data = gfc_conv_array_data (dest);
7443 lss_array->offset = gfc_conv_array_offset (dest);
7444 for (n = 0; n < cm->as->rank; n++)
7446 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7447 lss_array->stride[n] = gfc_index_one_node;
7449 mpz_init (lss_array->shape[n]);
7450 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7451 cm->as->lower[n]->value.integer);
7452 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7455 /* Associate the SS with the loop. */
7456 gfc_add_ss_to_loop (&loop, lss);
7457 gfc_add_ss_to_loop (&loop, rss);
7459 /* Calculate the bounds of the scalarization. */
7460 gfc_conv_ss_startstride (&loop);
7462 /* Setup the scalarizing loops. */
7463 gfc_conv_loop_setup (&loop, &expr->where);
7465 /* Setup the gfc_se structures. */
7466 gfc_copy_loopinfo_to_se (&lse, &loop);
7467 gfc_copy_loopinfo_to_se (&rse, &loop);
7470 gfc_mark_ss_chain_used (rss, 1);
7472 gfc_mark_ss_chain_used (lss, 1);
7474 /* Start the scalarized loop body. */
7475 gfc_start_scalarized_body (&loop, &body);
7477 gfc_conv_tmp_array_ref (&lse);
7478 if (cm->ts.type == BT_CHARACTER)
7479 lse.string_length = cm->ts.u.cl->backend_decl;
7481 gfc_conv_expr (&rse, expr);
7483 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7484 gfc_add_expr_to_block (&body, tmp);
7486 gcc_assert (rse.ss == gfc_ss_terminator);
7488 /* Generate the copying loops. */
7489 gfc_trans_scalarizing_loops (&loop, &body);
7491 /* Wrap the whole thing up. */
7492 gfc_add_block_to_block (&block, &loop.pre);
7493 gfc_add_block_to_block (&block, &loop.post);
7495 gcc_assert (lss_array->shape != NULL);
7496 gfc_free_shape (&lss_array->shape, cm->as->rank);
7497 gfc_cleanup_loop (&loop);
7499 return gfc_finish_block (&block);
7504 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7514 gfc_expr *arg = NULL;
7516 gfc_start_block (&block);
7517 gfc_init_se (&se, NULL);
7519 /* Get the descriptor for the expressions. */
7520 se.want_pointer = 0;
7521 gfc_conv_expr_descriptor (&se, expr);
7522 gfc_add_block_to_block (&block, &se.pre);
7523 gfc_add_modify (&block, dest, se.expr);
7525 /* Deal with arrays of derived types with allocatable components. */
7526 if (gfc_bt_struct (cm->ts.type)
7527 && cm->ts.u.derived->attr.alloc_comp)
7528 // TODO: Fix caf_mode
7529 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7532 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7533 && CLASS_DATA(cm)->attr.allocatable)
7535 if (cm->ts.u.derived->attr.alloc_comp)
7536 // TODO: Fix caf_mode
7537 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7542 tmp = TREE_TYPE (dest);
7543 tmp = gfc_duplicate_allocatable (dest, se.expr,
7544 tmp, expr->rank, NULL_TREE);
7548 tmp = gfc_duplicate_allocatable (dest, se.expr,
7549 TREE_TYPE(cm->backend_decl),
7550 cm->as->rank, NULL_TREE);
7552 gfc_add_expr_to_block (&block, tmp);
7553 gfc_add_block_to_block (&block, &se.post);
7555 if (expr->expr_type != EXPR_VARIABLE)
7556 gfc_conv_descriptor_data_set (&block, se.expr,
7559 /* We need to know if the argument of a conversion function is a
7560 variable, so that the correct lower bound can be used. */
7561 if (expr->expr_type == EXPR_FUNCTION
7562 && expr->value.function.isym
7563 && expr->value.function.isym->conversion
7564 && expr->value.function.actual->expr
7565 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7566 arg = expr->value.function.actual->expr;
7568 /* Obtain the array spec of full array references. */
7570 as = gfc_get_full_arrayspec_from_expr (arg);
7572 as = gfc_get_full_arrayspec_from_expr (expr);
7574 /* Shift the lbound and ubound of temporaries to being unity,
7575 rather than zero, based. Always calculate the offset. */
7576 offset = gfc_conv_descriptor_offset_get (dest);
7577 gfc_add_modify (&block, offset, gfc_index_zero_node);
7578 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7580 for (n = 0; n < expr->rank; n++)
7585 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7586 TODO It looks as if gfc_conv_expr_descriptor should return
7587 the correct bounds and that the following should not be
7588 necessary. This would simplify gfc_conv_intrinsic_bound
7590 if (as && as->lower[n])
7593 gfc_init_se (&lbse, NULL);
7594 gfc_conv_expr (&lbse, as->lower[n]);
7595 gfc_add_block_to_block (&block, &lbse.pre);
7596 lbound = gfc_evaluate_now (lbse.expr, &block);
7600 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7601 lbound = gfc_conv_descriptor_lbound_get (tmp,
7605 lbound = gfc_conv_descriptor_lbound_get (dest,
7608 lbound = gfc_index_one_node;
7610 lbound = fold_convert (gfc_array_index_type, lbound);
7612 /* Shift the bounds and set the offset accordingly. */
7613 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7614 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7615 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7616 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7618 gfc_conv_descriptor_ubound_set (&block, dest,
7619 gfc_rank_cst[n], tmp);
7620 gfc_conv_descriptor_lbound_set (&block, dest,
7621 gfc_rank_cst[n], lbound);
7623 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7624 gfc_conv_descriptor_lbound_get (dest,
7626 gfc_conv_descriptor_stride_get (dest,
7628 gfc_add_modify (&block, tmp2, tmp);
7629 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7631 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7636 /* If a conversion expression has a null data pointer
7637 argument, nullify the allocatable component. */
7641 if (arg->symtree->n.sym->attr.allocatable
7642 || arg->symtree->n.sym->attr.pointer)
7644 non_null_expr = gfc_finish_block (&block);
7645 gfc_start_block (&block);
7646 gfc_conv_descriptor_data_set (&block, dest,
7648 null_expr = gfc_finish_block (&block);
7649 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7650 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7651 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7652 return build3_v (COND_EXPR, tmp,
7653 null_expr, non_null_expr);
7657 return gfc_finish_block (&block);
7661 /* Allocate or reallocate scalar component, as necessary. */
7664 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7674 tree lhs_cl_size = NULL_TREE;
7679 if (!expr2 || expr2->rank)
7682 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7684 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7686 char name[GFC_MAX_SYMBOL_LEN+9];
7687 gfc_component *strlen;
7688 /* Use the rhs string length and the lhs element size. */
7689 gcc_assert (expr2->ts.type == BT_CHARACTER);
7690 if (!expr2->ts.u.cl->backend_decl)
7692 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7693 gcc_assert (expr2->ts.u.cl->backend_decl);
7696 size = expr2->ts.u.cl->backend_decl;
7698 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7700 sprintf (name, "_%s_length", cm->name);
7701 strlen = gfc_find_component (sym, name, true, true, NULL);
7702 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7703 gfc_charlen_type_node,
7704 TREE_OPERAND (comp, 0),
7705 strlen->backend_decl, NULL_TREE);
7707 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7708 tmp = TYPE_SIZE_UNIT (tmp);
7709 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7710 TREE_TYPE (tmp), tmp,
7711 fold_convert (TREE_TYPE (tmp), size));
7713 else if (cm->ts.type == BT_CLASS)
7715 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7716 if (expr2->ts.type == BT_DERIVED)
7718 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7719 size = TYPE_SIZE_UNIT (tmp);
7725 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7726 gfc_add_vptr_component (e2vtab);
7727 gfc_add_size_component (e2vtab);
7728 gfc_init_se (&se, NULL);
7729 gfc_conv_expr (&se, e2vtab);
7730 gfc_add_block_to_block (block, &se.pre);
7731 size = fold_convert (size_type_node, se.expr);
7732 gfc_free_expr (e2vtab);
7734 size_in_bytes = size;
7738 /* Otherwise use the length in bytes of the rhs. */
7739 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7740 size_in_bytes = size;
7743 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7744 size_in_bytes, size_one_node);
7746 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7748 tmp = build_call_expr_loc (input_location,
7749 builtin_decl_explicit (BUILT_IN_CALLOC),
7750 2, build_one_cst (size_type_node),
7752 tmp = fold_convert (TREE_TYPE (comp), tmp);
7753 gfc_add_modify (block, comp, tmp);
7757 tmp = build_call_expr_loc (input_location,
7758 builtin_decl_explicit (BUILT_IN_MALLOC),
7760 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7761 ptr = gfc_class_data_get (comp);
7764 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7765 gfc_add_modify (block, ptr, tmp);
7768 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7769 /* Update the lhs character length. */
7770 gfc_add_modify (block, lhs_cl_size,
7771 fold_convert (TREE_TYPE (lhs_cl_size), size));
7775 /* Assign a single component of a derived type constructor. */
7778 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7779 gfc_symbol *sym, bool init)
7787 gfc_start_block (&block);
7789 if (cm->attr.pointer || cm->attr.proc_pointer)
7791 /* Only care about pointers here, not about allocatables. */
7792 gfc_init_se (&se, NULL);
7793 /* Pointer component. */
7794 if ((cm->attr.dimension || cm->attr.codimension)
7795 && !cm->attr.proc_pointer)
7797 /* Array pointer. */
7798 if (expr->expr_type == EXPR_NULL)
7799 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7802 se.direct_byref = 1;
7804 gfc_conv_expr_descriptor (&se, expr);
7805 gfc_add_block_to_block (&block, &se.pre);
7806 gfc_add_block_to_block (&block, &se.post);
7811 /* Scalar pointers. */
7812 se.want_pointer = 1;
7813 gfc_conv_expr (&se, expr);
7814 gfc_add_block_to_block (&block, &se.pre);
7816 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7817 && expr->symtree->n.sym->attr.dummy)
7818 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7820 gfc_add_modify (&block, dest,
7821 fold_convert (TREE_TYPE (dest), se.expr));
7822 gfc_add_block_to_block (&block, &se.post);
7825 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7827 /* NULL initialization for CLASS components. */
7828 tmp = gfc_trans_structure_assign (dest,
7829 gfc_class_initializer (&cm->ts, expr),
7831 gfc_add_expr_to_block (&block, tmp);
7833 else if ((cm->attr.dimension || cm->attr.codimension)
7834 && !cm->attr.proc_pointer)
7836 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7837 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7838 else if (cm->attr.allocatable || cm->attr.pdt_array)
7840 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7841 gfc_add_expr_to_block (&block, tmp);
7845 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7846 gfc_add_expr_to_block (&block, tmp);
7849 else if (cm->ts.type == BT_CLASS
7850 && CLASS_DATA (cm)->attr.dimension
7851 && CLASS_DATA (cm)->attr.allocatable
7852 && expr->ts.type == BT_DERIVED)
7854 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7855 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7856 tmp = gfc_class_vptr_get (dest);
7857 gfc_add_modify (&block, tmp,
7858 fold_convert (TREE_TYPE (tmp), vtab));
7859 tmp = gfc_class_data_get (dest);
7860 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7861 gfc_add_expr_to_block (&block, tmp);
7863 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7865 /* NULL initialization for allocatable components. */
7866 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7867 null_pointer_node));
7869 else if (init && (cm->attr.allocatable
7870 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7871 && expr->ts.type != BT_CLASS)))
7873 /* Take care about non-array allocatable components here. The alloc_*
7874 routine below is motivated by the alloc_scalar_allocatable_for_
7875 assignment() routine, but with the realloc portions removed and
7877 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7882 /* The remainder of these instructions follow the if (cm->attr.pointer)
7883 if (!cm->attr.dimension) part above. */
7884 gfc_init_se (&se, NULL);
7885 gfc_conv_expr (&se, expr);
7886 gfc_add_block_to_block (&block, &se.pre);
7888 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7889 && expr->symtree->n.sym->attr.dummy)
7890 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7892 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7894 tmp = gfc_class_data_get (dest);
7895 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7896 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7897 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7898 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7899 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7902 tmp = build_fold_indirect_ref_loc (input_location, dest);
7904 /* For deferred strings insert a memcpy. */
7905 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7908 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7909 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7911 : expr->ts.u.cl->backend_decl);
7912 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7913 gfc_add_expr_to_block (&block, tmp);
7916 gfc_add_modify (&block, tmp,
7917 fold_convert (TREE_TYPE (tmp), se.expr));
7918 gfc_add_block_to_block (&block, &se.post);
7920 else if (expr->ts.type == BT_UNION)
7923 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7924 /* We mark that the entire union should be initialized with a contrived
7925 EXPR_NULL expression at the beginning. */
7926 if (c != NULL && c->n.component == NULL
7927 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7929 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7930 dest, build_constructor (TREE_TYPE (dest), NULL));
7931 gfc_add_expr_to_block (&block, tmp);
7932 c = gfc_constructor_next (c);
7934 /* The following constructor expression, if any, represents a specific
7935 map intializer, as given by the user. */
7936 if (c != NULL && c->expr != NULL)
7938 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7939 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7940 gfc_add_expr_to_block (&block, tmp);
7943 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7945 if (expr->expr_type != EXPR_STRUCTURE)
7947 tree dealloc = NULL_TREE;
7948 gfc_init_se (&se, NULL);
7949 gfc_conv_expr (&se, expr);
7950 gfc_add_block_to_block (&block, &se.pre);
7951 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7952 expression in a temporary variable and deallocate the allocatable
7953 components. Then we can the copy the expression to the result. */
7954 if (cm->ts.u.derived->attr.alloc_comp
7955 && expr->expr_type != EXPR_VARIABLE)
7957 se.expr = gfc_evaluate_now (se.expr, &block);
7958 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7961 gfc_add_modify (&block, dest,
7962 fold_convert (TREE_TYPE (dest), se.expr));
7963 if (cm->ts.u.derived->attr.alloc_comp
7964 && expr->expr_type != EXPR_NULL)
7966 // TODO: Fix caf_mode
7967 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7968 dest, expr->rank, 0);
7969 gfc_add_expr_to_block (&block, tmp);
7970 if (dealloc != NULL_TREE)
7971 gfc_add_expr_to_block (&block, dealloc);
7973 gfc_add_block_to_block (&block, &se.post);
7977 /* Nested constructors. */
7978 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7979 gfc_add_expr_to_block (&block, tmp);
7982 else if (gfc_deferred_strlen (cm, &tmp))
7986 gcc_assert (strlen);
7987 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7989 TREE_OPERAND (dest, 0),
7992 if (expr->expr_type == EXPR_NULL)
7994 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7995 gfc_add_modify (&block, dest, tmp);
7996 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7997 gfc_add_modify (&block, strlen, tmp);
8002 gfc_init_se (&se, NULL);
8003 gfc_conv_expr (&se, expr);
8004 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8005 tmp = build_call_expr_loc (input_location,
8006 builtin_decl_explicit (BUILT_IN_MALLOC),
8008 gfc_add_modify (&block, dest,
8009 fold_convert (TREE_TYPE (dest), tmp));
8010 gfc_add_modify (&block, strlen,
8011 fold_convert (TREE_TYPE (strlen), se.string_length));
8012 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8013 gfc_add_expr_to_block (&block, tmp);
8016 else if (!cm->attr.artificial)
8018 /* Scalar component (excluding deferred parameters). */
8019 gfc_init_se (&se, NULL);
8020 gfc_init_se (&lse, NULL);
8022 gfc_conv_expr (&se, expr);
8023 if (cm->ts.type == BT_CHARACTER)
8024 lse.string_length = cm->ts.u.cl->backend_decl;
8026 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8027 gfc_add_expr_to_block (&block, tmp);
8029 return gfc_finish_block (&block);
8032 /* Assign a derived type constructor to a variable. */
8035 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8044 gfc_start_block (&block);
8045 cm = expr->ts.u.derived->components;
8047 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8048 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8049 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8053 gfc_init_se (&se, NULL);
8054 gfc_init_se (&lse, NULL);
8055 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8057 gfc_add_modify (&block, lse.expr,
8058 fold_convert (TREE_TYPE (lse.expr), se.expr));
8060 return gfc_finish_block (&block);
8064 gfc_init_se (&se, NULL);
8066 for (c = gfc_constructor_first (expr->value.constructor);
8067 c; c = gfc_constructor_next (c), cm = cm->next)
8069 /* Skip absent members in default initializers. */
8070 if (!c->expr && !cm->attr.allocatable)
8073 /* Register the component with the caf-lib before it is initialized.
8074 Register only allocatable components, that are not coarray'ed
8075 components (%comp[*]). Only register when the constructor is not the
8077 if (coarray && !cm->attr.codimension
8078 && (cm->attr.allocatable || cm->attr.pointer)
8079 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8081 tree token, desc, size;
8082 bool is_array = cm->ts.type == BT_CLASS
8083 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8085 field = cm->backend_decl;
8086 field = fold_build3_loc (input_location, COMPONENT_REF,
8087 TREE_TYPE (field), dest, field, NULL_TREE);
8088 if (cm->ts.type == BT_CLASS)
8089 field = gfc_class_data_get (field);
8091 token = is_array ? gfc_conv_descriptor_token (field)
8092 : fold_build3_loc (input_location, COMPONENT_REF,
8093 TREE_TYPE (cm->caf_token), dest,
8094 cm->caf_token, NULL_TREE);
8098 /* The _caf_register routine looks at the rank of the array
8099 descriptor to decide whether the data registered is an array
8101 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8103 /* When the rank is not known just set a positive rank, which
8104 suffices to recognize the data as array. */
8107 size = build_zero_cst (size_type_node);
8109 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8110 build_int_cst (signed_char_type_node, rank));
8114 desc = gfc_conv_scalar_to_descriptor (&se, field,
8115 cm->ts.type == BT_CLASS
8116 ? CLASS_DATA (cm)->attr
8118 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8120 gfc_add_block_to_block (&block, &se.pre);
8121 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8122 7, size, build_int_cst (
8124 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8125 gfc_build_addr_expr (pvoid_type_node,
8127 gfc_build_addr_expr (NULL_TREE, desc),
8128 null_pointer_node, null_pointer_node,
8130 gfc_add_expr_to_block (&block, tmp);
8132 field = cm->backend_decl;
8133 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8134 dest, field, NULL_TREE);
8137 gfc_expr *e = gfc_get_null_expr (NULL);
8138 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8143 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8144 expr->ts.u.derived, init);
8145 gfc_add_expr_to_block (&block, tmp);
8147 return gfc_finish_block (&block);
8151 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8152 gfc_component *un, gfc_expr *init)
8154 gfc_constructor *ctor;
8156 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8159 ctor = gfc_constructor_first (init->value.constructor);
8161 if (ctor == NULL || ctor->expr == NULL)
8164 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8166 /* If we have an 'initialize all' constructor, do it first. */
8167 if (ctor->expr->expr_type == EXPR_NULL)
8169 tree union_type = TREE_TYPE (un->backend_decl);
8170 tree val = build_constructor (union_type, NULL);
8171 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8172 ctor = gfc_constructor_next (ctor);
8175 /* Add the map initializer on top. */
8176 if (ctor != NULL && ctor->expr != NULL)
8178 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8179 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8180 TREE_TYPE (un->backend_decl),
8181 un->attr.dimension, un->attr.pointer,
8182 un->attr.proc_pointer);
8183 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8187 /* Build an expression for a constructor. If init is nonzero then
8188 this is part of a static variable initializer. */
8191 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8198 vec<constructor_elt, va_gc> *v = NULL;
8200 gcc_assert (se->ss == NULL);
8201 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8202 type = gfc_typenode_for_spec (&expr->ts);
8206 /* Create a temporary variable and fill it in. */
8207 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8208 /* The symtree in expr is NULL, if the code to generate is for
8209 initializing the static members only. */
8210 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8212 gfc_add_expr_to_block (&se->pre, tmp);
8216 cm = expr->ts.u.derived->components;
8218 for (c = gfc_constructor_first (expr->value.constructor);
8219 c; c = gfc_constructor_next (c), cm = cm->next)
8221 /* Skip absent members in default initializers and allocatable
8222 components. Although the latter have a default initializer
8223 of EXPR_NULL,... by default, the static nullify is not needed
8224 since this is done every time we come into scope. */
8225 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8228 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8229 && strcmp (cm->name, "_extends") == 0
8230 && cm->initializer->symtree)
8234 vtabs = cm->initializer->symtree->n.sym;
8235 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8236 vtab = unshare_expr_without_location (vtab);
8237 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8239 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8241 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8242 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8243 fold_convert (TREE_TYPE (cm->backend_decl),
8246 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8247 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8248 fold_convert (TREE_TYPE (cm->backend_decl),
8249 integer_zero_node));
8250 else if (cm->ts.type == BT_UNION)
8251 gfc_conv_union_initializer (v, cm, c->expr);
8254 val = gfc_conv_initializer (c->expr, &cm->ts,
8255 TREE_TYPE (cm->backend_decl),
8256 cm->attr.dimension, cm->attr.pointer,
8257 cm->attr.proc_pointer);
8258 val = unshare_expr_without_location (val);
8260 /* Append it to the constructor list. */
8261 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8265 se->expr = build_constructor (type, v);
8267 TREE_CONSTANT (se->expr) = 1;
8271 /* Translate a substring expression. */
8274 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8280 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8282 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8283 expr->value.character.length,
8284 expr->value.character.string);
8286 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8287 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8290 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8294 /* Entry point for expression translation. Evaluates a scalar quantity.
8295 EXPR is the expression to be translated, and SE is the state structure if
8296 called from within the scalarized. */
8299 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8304 if (ss && ss->info->expr == expr
8305 && (ss->info->type == GFC_SS_SCALAR
8306 || ss->info->type == GFC_SS_REFERENCE))
8308 gfc_ss_info *ss_info;
8311 /* Substitute a scalar expression evaluated outside the scalarization
8313 se->expr = ss_info->data.scalar.value;
8314 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8315 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8317 se->string_length = ss_info->string_length;
8318 gfc_advance_se_ss_chain (se);
8322 /* We need to convert the expressions for the iso_c_binding derived types.
8323 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8324 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8325 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8326 updated to be an integer with a kind equal to the size of a (void *). */
8327 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8328 && expr->ts.u.derived->attr.is_bind_c)
8330 if (expr->expr_type == EXPR_VARIABLE
8331 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8332 || expr->symtree->n.sym->intmod_sym_id
8333 == ISOCBINDING_NULL_FUNPTR))
8335 /* Set expr_type to EXPR_NULL, which will result in
8336 null_pointer_node being used below. */
8337 expr->expr_type = EXPR_NULL;
8341 /* Update the type/kind of the expression to be what the new
8342 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8343 expr->ts.type = BT_INTEGER;
8344 expr->ts.f90_type = BT_VOID;
8345 expr->ts.kind = gfc_index_integer_kind;
8349 gfc_fix_class_refs (expr);
8351 switch (expr->expr_type)
8354 gfc_conv_expr_op (se, expr);
8358 gfc_conv_function_expr (se, expr);
8362 gfc_conv_constant (se, expr);
8366 gfc_conv_variable (se, expr);
8370 se->expr = null_pointer_node;
8373 case EXPR_SUBSTRING:
8374 gfc_conv_substring_expr (se, expr);
8377 case EXPR_STRUCTURE:
8378 gfc_conv_structure (se, expr, 0);
8382 gfc_conv_array_constructor_expr (se, expr);
8391 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8392 of an assignment. */
8394 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8396 gfc_conv_expr (se, expr);
8397 /* All numeric lvalues should have empty post chains. If not we need to
8398 figure out a way of rewriting an lvalue so that it has no post chain. */
8399 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8402 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8403 numeric expressions. Used for scalar values where inserting cleanup code
8406 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8410 gcc_assert (expr->ts.type != BT_CHARACTER);
8411 gfc_conv_expr (se, expr);
8414 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8415 gfc_add_modify (&se->pre, val, se->expr);
8417 gfc_add_block_to_block (&se->pre, &se->post);
8421 /* Helper to translate an expression and convert it to a particular type. */
8423 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8425 gfc_conv_expr_val (se, expr);
8426 se->expr = convert (type, se->expr);
8430 /* Converts an expression so that it can be passed by reference. Scalar
8434 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8440 if (ss && ss->info->expr == expr
8441 && ss->info->type == GFC_SS_REFERENCE)
8443 /* Returns a reference to the scalar evaluated outside the loop
8445 gfc_conv_expr (se, expr);
8447 if (expr->ts.type == BT_CHARACTER
8448 && expr->expr_type != EXPR_FUNCTION)
8449 gfc_conv_string_parameter (se);
8451 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8456 if (expr->ts.type == BT_CHARACTER)
8458 gfc_conv_expr (se, expr);
8459 gfc_conv_string_parameter (se);
8463 if (expr->expr_type == EXPR_VARIABLE)
8465 se->want_pointer = 1;
8466 gfc_conv_expr (se, expr);
8469 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8470 gfc_add_modify (&se->pre, var, se->expr);
8471 gfc_add_block_to_block (&se->pre, &se->post);
8474 else if (add_clobber && expr->ref == NULL)
8478 /* FIXME: This fails if var is passed by reference, see PR
8480 var = expr->symtree->n.sym->backend_decl;
8481 clobber = build_clobber (TREE_TYPE (var));
8482 gfc_add_modify (&se->pre, var, clobber);
8487 if (expr->expr_type == EXPR_FUNCTION
8488 && ((expr->value.function.esym
8489 && expr->value.function.esym->result->attr.pointer
8490 && !expr->value.function.esym->result->attr.dimension)
8491 || (!expr->value.function.esym && !expr->ref
8492 && expr->symtree->n.sym->attr.pointer
8493 && !expr->symtree->n.sym->attr.dimension)))
8495 se->want_pointer = 1;
8496 gfc_conv_expr (se, expr);
8497 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8498 gfc_add_modify (&se->pre, var, se->expr);
8503 gfc_conv_expr (se, expr);
8505 /* Create a temporary var to hold the value. */
8506 if (TREE_CONSTANT (se->expr))
8508 tree tmp = se->expr;
8509 STRIP_TYPE_NOPS (tmp);
8510 var = build_decl (input_location,
8511 CONST_DECL, NULL, TREE_TYPE (tmp));
8512 DECL_INITIAL (var) = tmp;
8513 TREE_STATIC (var) = 1;
8518 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8519 gfc_add_modify (&se->pre, var, se->expr);
8522 if (!expr->must_finalize)
8523 gfc_add_block_to_block (&se->pre, &se->post);
8525 /* Take the address of that value. */
8526 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8530 /* Get the _len component for an unlimited polymorphic expression. */
8533 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8536 gfc_ref *ref = expr->ref;
8538 gfc_init_se (&se, NULL);
8539 while (ref && ref->next)
8541 gfc_add_len_component (expr);
8542 gfc_conv_expr (&se, expr);
8543 gfc_add_block_to_block (block, &se.pre);
8544 gcc_assert (se.post.head == NULL_TREE);
8547 gfc_free_ref_list (ref->next);
8552 gfc_free_ref_list (expr->ref);
8559 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8560 statement-list outside of the scalarizer-loop. When code is generated, that
8561 depends on the scalarized expression, it is added to RSE.PRE.
8562 Returns le's _vptr tree and when set the len expressions in to_lenp and
8563 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8567 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8568 gfc_expr * re, gfc_se *rse,
8569 tree * to_lenp, tree * from_lenp)
8572 gfc_expr * vptr_expr;
8573 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8574 bool set_vptr = false, temp_rhs = false;
8575 stmtblock_t *pre = block;
8577 /* Create a temporary for complicated expressions. */
8578 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8579 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8581 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8583 gfc_add_modify (&rse->pre, tmp, rse->expr);
8588 /* Get the _vptr for the left-hand side expression. */
8589 gfc_init_se (&se, NULL);
8590 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8591 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8593 /* Care about _len for unlimited polymorphic entities. */
8594 if (UNLIMITED_POLY (vptr_expr)
8595 || (vptr_expr->ts.type == BT_DERIVED
8596 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8597 to_len = trans_get_upoly_len (block, vptr_expr);
8598 gfc_add_vptr_component (vptr_expr);
8602 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8603 se.want_pointer = 1;
8604 gfc_conv_expr (&se, vptr_expr);
8605 gfc_free_expr (vptr_expr);
8606 gfc_add_block_to_block (block, &se.pre);
8607 gcc_assert (se.post.head == NULL_TREE);
8609 STRIP_NOPS (lhs_vptr);
8611 /* Set the _vptr only when the left-hand side of the assignment is a
8615 /* Get the vptr from the rhs expression only, when it is variable.
8616 Functions are expected to be assigned to a temporary beforehand. */
8617 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8618 ? gfc_find_and_cut_at_last_class_ref (re)
8620 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8622 if (to_len != NULL_TREE)
8624 /* Get the _len information from the rhs. */
8625 if (UNLIMITED_POLY (vptr_expr)
8626 || (vptr_expr->ts.type == BT_DERIVED
8627 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8628 from_len = trans_get_upoly_len (block, vptr_expr);
8630 gfc_add_vptr_component (vptr_expr);
8634 if (re->expr_type == EXPR_VARIABLE
8635 && DECL_P (re->symtree->n.sym->backend_decl)
8636 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8637 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8638 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8639 re->symtree->n.sym->backend_decl))))
8642 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8643 re->symtree->n.sym->backend_decl));
8645 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8646 re->symtree->n.sym->backend_decl));
8648 else if (temp_rhs && re->ts.type == BT_CLASS)
8651 se.expr = gfc_class_vptr_get (rse->expr);
8652 if (UNLIMITED_POLY (re))
8653 from_len = gfc_class_len_get (rse->expr);
8655 else if (re->expr_type != EXPR_NULL)
8656 /* Only when rhs is non-NULL use its declared type for vptr
8658 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8660 /* When the rhs is NULL use the vtab of lhs' declared type. */
8661 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8666 gfc_init_se (&se, NULL);
8667 se.want_pointer = 1;
8668 gfc_conv_expr (&se, vptr_expr);
8669 gfc_free_expr (vptr_expr);
8670 gfc_add_block_to_block (block, &se.pre);
8671 gcc_assert (se.post.head == NULL_TREE);
8673 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8676 if (to_len != NULL_TREE)
8678 /* The _len component needs to be set. Figure how to get the
8679 value of the right-hand side. */
8680 if (from_len == NULL_TREE)
8682 if (rse->string_length != NULL_TREE)
8683 from_len = rse->string_length;
8684 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8686 from_len = gfc_get_expr_charlen (re);
8687 gfc_init_se (&se, NULL);
8688 gfc_conv_expr (&se, re->ts.u.cl->length);
8689 gfc_add_block_to_block (block, &se.pre);
8690 gcc_assert (se.post.head == NULL_TREE);
8691 from_len = gfc_evaluate_now (se.expr, block);
8694 from_len = build_zero_cst (gfc_charlen_type_node);
8696 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8701 /* Return the _len trees only, when requested. */
8705 *from_lenp = from_len;
8710 /* Assign tokens for pointer components. */
8713 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8716 symbol_attribute lhs_attr, rhs_attr;
8717 tree tmp, lhs_tok, rhs_tok;
8718 /* Flag to indicated component refs on the rhs. */
8721 lhs_attr = gfc_caf_attr (expr1);
8722 if (expr2->expr_type != EXPR_NULL)
8724 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8725 if (lhs_attr.codimension && rhs_attr.codimension)
8727 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8728 lhs_tok = build_fold_indirect_ref (lhs_tok);
8731 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8735 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8736 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8739 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8741 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8742 gfc_prepend_expr_to_block (&lse->post, tmp);
8745 else if (lhs_attr.codimension)
8747 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8748 lhs_tok = build_fold_indirect_ref (lhs_tok);
8749 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8750 lhs_tok, null_pointer_node);
8751 gfc_prepend_expr_to_block (&lse->post, tmp);
8755 /* Indentify class valued proc_pointer assignments. */
8758 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8763 while (ref && ref->next)
8766 return ref && ref->type == REF_COMPONENT
8767 && ref->u.c.component->attr.proc_pointer
8768 && expr2->expr_type == EXPR_VARIABLE
8769 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8773 /* Do everything that is needed for a CLASS function expr2. */
8776 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8777 gfc_expr *expr1, gfc_expr *expr2)
8779 tree expr1_vptr = NULL_TREE;
8782 gfc_conv_function_expr (rse, expr2);
8783 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8785 if (expr1->ts.type != BT_CLASS)
8786 rse->expr = gfc_class_data_get (rse->expr);
8789 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8792 gfc_add_block_to_block (block, &rse->pre);
8793 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8794 gfc_add_modify (&lse->pre, tmp, rse->expr);
8796 gfc_add_modify (&lse->pre, expr1_vptr,
8797 fold_convert (TREE_TYPE (expr1_vptr),
8798 gfc_class_vptr_get (tmp)));
8799 rse->expr = gfc_class_data_get (tmp);
8807 gfc_trans_pointer_assign (gfc_code * code)
8809 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8813 /* Generate code for a pointer assignment. */
8816 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8823 tree expr1_vptr = NULL_TREE;
8824 bool scalar, non_proc_pointer_assign;
8827 gfc_start_block (&block);
8829 gfc_init_se (&lse, NULL);
8831 /* Usually testing whether this is not a proc pointer assignment. */
8832 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8834 /* Check whether the expression is a scalar or not; we cannot use
8835 expr1->rank as it can be nonzero for proc pointers. */
8836 ss = gfc_walk_expr (expr1);
8837 scalar = ss == gfc_ss_terminator;
8839 gfc_free_ss_chain (ss);
8841 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8842 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8844 gfc_add_data_component (expr2);
8845 /* The following is required as gfc_add_data_component doesn't
8846 update ts.type if there is a tailing REF_ARRAY. */
8847 expr2->ts.type = BT_DERIVED;
8852 /* Scalar pointers. */
8853 lse.want_pointer = 1;
8854 gfc_conv_expr (&lse, expr1);
8855 gfc_init_se (&rse, NULL);
8856 rse.want_pointer = 1;
8857 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8858 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8860 gfc_conv_expr (&rse, expr2);
8862 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8864 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8866 lse.expr = gfc_class_data_get (lse.expr);
8869 if (expr1->symtree->n.sym->attr.proc_pointer
8870 && expr1->symtree->n.sym->attr.dummy)
8871 lse.expr = build_fold_indirect_ref_loc (input_location,
8874 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8875 && expr2->symtree->n.sym->attr.dummy)
8876 rse.expr = build_fold_indirect_ref_loc (input_location,
8879 gfc_add_block_to_block (&block, &lse.pre);
8880 gfc_add_block_to_block (&block, &rse.pre);
8882 /* Check character lengths if character expression. The test is only
8883 really added if -fbounds-check is enabled. Exclude deferred
8884 character length lefthand sides. */
8885 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8886 && !expr1->ts.deferred
8887 && !expr1->symtree->n.sym->attr.proc_pointer
8888 && !gfc_is_proc_ptr_comp (expr1))
8890 gcc_assert (expr2->ts.type == BT_CHARACTER);
8891 gcc_assert (lse.string_length && rse.string_length);
8892 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8893 lse.string_length, rse.string_length,
8897 /* The assignment to an deferred character length sets the string
8898 length to that of the rhs. */
8899 if (expr1->ts.deferred)
8901 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8902 gfc_add_modify (&block, lse.string_length,
8903 fold_convert (TREE_TYPE (lse.string_length),
8904 rse.string_length));
8905 else if (lse.string_length != NULL)
8906 gfc_add_modify (&block, lse.string_length,
8907 build_zero_cst (TREE_TYPE (lse.string_length)));
8910 gfc_add_modify (&block, lse.expr,
8911 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8913 /* Also set the tokens for pointer components in derived typed
8915 if (flag_coarray == GFC_FCOARRAY_LIB)
8916 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8918 gfc_add_block_to_block (&block, &rse.post);
8919 gfc_add_block_to_block (&block, &lse.post);
8926 tree strlen_rhs = NULL_TREE;
8928 /* Array pointer. Find the last reference on the LHS and if it is an
8929 array section ref, we're dealing with bounds remapping. In this case,
8930 set it to AR_FULL so that gfc_conv_expr_descriptor does
8931 not see it and process the bounds remapping afterwards explicitly. */
8932 for (remap = expr1->ref; remap; remap = remap->next)
8933 if (!remap->next && remap->type == REF_ARRAY
8934 && remap->u.ar.type == AR_SECTION)
8936 rank_remap = (remap && remap->u.ar.end[0]);
8938 gfc_init_se (&lse, NULL);
8940 lse.descriptor_only = 1;
8941 gfc_conv_expr_descriptor (&lse, expr1);
8942 strlen_lhs = lse.string_length;
8945 if (expr2->expr_type == EXPR_NULL)
8947 /* Just set the data pointer to null. */
8948 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8950 else if (rank_remap)
8952 /* If we are rank-remapping, just get the RHS's descriptor and
8953 process this later on. */
8954 gfc_init_se (&rse, NULL);
8955 rse.direct_byref = 1;
8956 rse.byref_noassign = 1;
8958 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8959 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8961 else if (expr2->expr_type == EXPR_FUNCTION)
8963 tree bound[GFC_MAX_DIMENSIONS];
8966 for (i = 0; i < expr2->rank; i++)
8967 bound[i] = NULL_TREE;
8968 tmp = gfc_typenode_for_spec (&expr2->ts);
8969 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8971 GFC_ARRAY_POINTER_CONT, false);
8972 tmp = gfc_create_var (tmp, "ptrtemp");
8973 rse.descriptor_only = 0;
8975 rse.direct_byref = 1;
8976 gfc_conv_expr_descriptor (&rse, expr2);
8977 strlen_rhs = rse.string_length;
8982 gfc_conv_expr_descriptor (&rse, expr2);
8983 strlen_rhs = rse.string_length;
8984 if (expr1->ts.type == BT_CLASS)
8985 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8990 else if (expr2->expr_type == EXPR_VARIABLE)
8992 /* Assign directly to the LHS's descriptor. */
8993 lse.descriptor_only = 0;
8994 lse.direct_byref = 1;
8995 gfc_conv_expr_descriptor (&lse, expr2);
8996 strlen_rhs = lse.string_length;
8998 if (expr1->ts.type == BT_CLASS)
9000 rse.expr = NULL_TREE;
9001 rse.string_length = NULL_TREE;
9002 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9008 /* If the target is not a whole array, use the target array
9009 reference for remap. */
9010 for (remap = expr2->ref; remap; remap = remap->next)
9011 if (remap->type == REF_ARRAY
9012 && remap->u.ar.type == AR_FULL
9017 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9019 gfc_init_se (&rse, NULL);
9020 rse.want_pointer = 1;
9021 gfc_conv_function_expr (&rse, expr2);
9022 if (expr1->ts.type != BT_CLASS)
9024 rse.expr = gfc_class_data_get (rse.expr);
9025 gfc_add_modify (&lse.pre, desc, rse.expr);
9026 /* Set the lhs span. */
9027 tmp = TREE_TYPE (rse.expr);
9028 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9029 tmp = fold_convert (gfc_array_index_type, tmp);
9030 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9034 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9037 gfc_add_block_to_block (&block, &rse.pre);
9038 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9039 gfc_add_modify (&lse.pre, tmp, rse.expr);
9041 gfc_add_modify (&lse.pre, expr1_vptr,
9042 fold_convert (TREE_TYPE (expr1_vptr),
9043 gfc_class_vptr_get (tmp)));
9044 rse.expr = gfc_class_data_get (tmp);
9045 gfc_add_modify (&lse.pre, desc, rse.expr);
9050 /* Assign to a temporary descriptor and then copy that
9051 temporary to the pointer. */
9052 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9053 lse.descriptor_only = 0;
9055 lse.direct_byref = 1;
9056 gfc_conv_expr_descriptor (&lse, expr2);
9057 strlen_rhs = lse.string_length;
9058 gfc_add_modify (&lse.pre, desc, tmp);
9061 gfc_add_block_to_block (&block, &lse.pre);
9063 gfc_add_block_to_block (&block, &rse.pre);
9065 /* If we do bounds remapping, update LHS descriptor accordingly. */
9069 gcc_assert (remap->u.ar.dimen == expr1->rank);
9073 /* Do rank remapping. We already have the RHS's descriptor
9074 converted in rse and now have to build the correct LHS
9075 descriptor for it. */
9077 tree dtype, data, span;
9079 tree lbound, ubound;
9082 dtype = gfc_conv_descriptor_dtype (desc);
9083 tmp = gfc_get_dtype (TREE_TYPE (desc));
9084 gfc_add_modify (&block, dtype, tmp);
9086 /* Copy data pointer. */
9087 data = gfc_conv_descriptor_data_get (rse.expr);
9088 gfc_conv_descriptor_data_set (&block, desc, data);
9090 /* Copy the span. */
9091 if (TREE_CODE (rse.expr) == VAR_DECL
9092 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9093 span = gfc_conv_descriptor_span_get (rse.expr);
9096 tmp = TREE_TYPE (rse.expr);
9097 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9098 span = fold_convert (gfc_array_index_type, tmp);
9100 gfc_conv_descriptor_span_set (&block, desc, span);
9102 /* Copy offset but adjust it such that it would correspond
9103 to a lbound of zero. */
9104 offs = gfc_conv_descriptor_offset_get (rse.expr);
9105 for (dim = 0; dim < expr2->rank; ++dim)
9107 stride = gfc_conv_descriptor_stride_get (rse.expr,
9109 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9111 tmp = fold_build2_loc (input_location, MULT_EXPR,
9112 gfc_array_index_type, stride, lbound);
9113 offs = fold_build2_loc (input_location, PLUS_EXPR,
9114 gfc_array_index_type, offs, tmp);
9116 gfc_conv_descriptor_offset_set (&block, desc, offs);
9118 /* Set the bounds as declared for the LHS and calculate strides as
9119 well as another offset update accordingly. */
9120 stride = gfc_conv_descriptor_stride_get (rse.expr,
9122 for (dim = 0; dim < expr1->rank; ++dim)
9127 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9129 /* Convert declared bounds. */
9130 gfc_init_se (&lower_se, NULL);
9131 gfc_init_se (&upper_se, NULL);
9132 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9133 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9135 gfc_add_block_to_block (&block, &lower_se.pre);
9136 gfc_add_block_to_block (&block, &upper_se.pre);
9138 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9139 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9141 lbound = gfc_evaluate_now (lbound, &block);
9142 ubound = gfc_evaluate_now (ubound, &block);
9144 gfc_add_block_to_block (&block, &lower_se.post);
9145 gfc_add_block_to_block (&block, &upper_se.post);
9147 /* Set bounds in descriptor. */
9148 gfc_conv_descriptor_lbound_set (&block, desc,
9149 gfc_rank_cst[dim], lbound);
9150 gfc_conv_descriptor_ubound_set (&block, desc,
9151 gfc_rank_cst[dim], ubound);
9154 stride = gfc_evaluate_now (stride, &block);
9155 gfc_conv_descriptor_stride_set (&block, desc,
9156 gfc_rank_cst[dim], stride);
9158 /* Update offset. */
9159 offs = gfc_conv_descriptor_offset_get (desc);
9160 tmp = fold_build2_loc (input_location, MULT_EXPR,
9161 gfc_array_index_type, lbound, stride);
9162 offs = fold_build2_loc (input_location, MINUS_EXPR,
9163 gfc_array_index_type, offs, tmp);
9164 offs = gfc_evaluate_now (offs, &block);
9165 gfc_conv_descriptor_offset_set (&block, desc, offs);
9167 /* Update stride. */
9168 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9169 stride = fold_build2_loc (input_location, MULT_EXPR,
9170 gfc_array_index_type, stride, tmp);
9175 /* Bounds remapping. Just shift the lower bounds. */
9177 gcc_assert (expr1->rank == expr2->rank);
9179 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9183 gcc_assert (!remap->u.ar.end[dim]);
9184 gfc_init_se (&lbound_se, NULL);
9185 if (remap->u.ar.start[dim])
9187 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9188 gfc_add_block_to_block (&block, &lbound_se.pre);
9191 /* This remap arises from a target that is not a whole
9192 array. The start expressions will be NULL but we need
9193 the lbounds to be one. */
9194 lbound_se.expr = gfc_index_one_node;
9195 gfc_conv_shift_descriptor_lbound (&block, desc,
9196 dim, lbound_se.expr);
9197 gfc_add_block_to_block (&block, &lbound_se.post);
9202 /* Check string lengths if applicable. The check is only really added
9203 to the output code if -fbounds-check is enabled. */
9204 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9206 gcc_assert (expr2->ts.type == BT_CHARACTER);
9207 gcc_assert (strlen_lhs && strlen_rhs);
9208 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9209 strlen_lhs, strlen_rhs, &block);
9212 /* If rank remapping was done, check with -fcheck=bounds that
9213 the target is at least as large as the pointer. */
9214 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9220 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9221 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9223 lsize = gfc_evaluate_now (lsize, &block);
9224 rsize = gfc_evaluate_now (rsize, &block);
9225 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9228 msg = _("Target of rank remapping is too small (%ld < %ld)");
9229 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9233 if (expr1->ts.type == BT_CHARACTER
9234 && expr1->symtree->n.sym->ts.deferred
9235 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9236 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9238 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9239 if (expr2->expr_type != EXPR_NULL)
9240 gfc_add_modify (&block, tmp,
9241 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9243 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9246 gfc_add_block_to_block (&block, &lse.post);
9248 gfc_add_block_to_block (&block, &rse.post);
9251 return gfc_finish_block (&block);
9255 /* Makes sure se is suitable for passing as a function string parameter. */
9256 /* TODO: Need to check all callers of this function. It may be abused. */
9259 gfc_conv_string_parameter (gfc_se * se)
9263 if (TREE_CODE (se->expr) == STRING_CST)
9265 type = TREE_TYPE (TREE_TYPE (se->expr));
9266 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9270 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9272 if (TREE_CODE (se->expr) != INDIRECT_REF)
9274 type = TREE_TYPE (se->expr);
9275 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9279 type = gfc_get_character_type_len (gfc_default_character_kind,
9281 type = build_pointer_type (type);
9282 se->expr = gfc_build_addr_expr (type, se->expr);
9286 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9290 /* Generate code for assignment of scalar variables. Includes character
9291 strings and derived types with allocatable components.
9292 If you know that the LHS has no allocations, set dealloc to false.
9294 DEEP_COPY has no effect if the typespec TS is not a derived type with
9295 allocatable components. Otherwise, if it is set, an explicit copy of each
9296 allocatable component is made. This is necessary as a simple copy of the
9297 whole object would copy array descriptors as is, so that the lhs's
9298 allocatable components would point to the rhs's after the assignment.
9299 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9300 necessary if the rhs is a non-pointer function, as the allocatable components
9301 are not accessible by other means than the function's result after the
9302 function has returned. It is even more subtle when temporaries are involved,
9303 as the two following examples show:
9304 1. When we evaluate an array constructor, a temporary is created. Thus
9305 there is theoretically no alias possible. However, no deep copy is
9306 made for this temporary, so that if the constructor is made of one or
9307 more variable with allocatable components, those components still point
9308 to the variable's: DEEP_COPY should be set for the assignment from the
9309 temporary to the lhs in that case.
9310 2. When assigning a scalar to an array, we evaluate the scalar value out
9311 of the loop, store it into a temporary variable, and assign from that.
9312 In that case, deep copying when assigning to the temporary would be a
9313 waste of resources; however deep copies should happen when assigning from
9314 the temporary to each array element: again DEEP_COPY should be set for
9315 the assignment from the temporary to the lhs. */
9318 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9319 bool deep_copy, bool dealloc, bool in_coarray)
9325 gfc_init_block (&block);
9327 if (ts.type == BT_CHARACTER)
9332 if (lse->string_length != NULL_TREE)
9334 gfc_conv_string_parameter (lse);
9335 gfc_add_block_to_block (&block, &lse->pre);
9336 llen = lse->string_length;
9339 if (rse->string_length != NULL_TREE)
9341 gfc_conv_string_parameter (rse);
9342 gfc_add_block_to_block (&block, &rse->pre);
9343 rlen = rse->string_length;
9346 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9347 rse->expr, ts.kind);
9349 else if (gfc_bt_struct (ts.type)
9350 && (ts.u.derived->attr.alloc_comp
9351 || (deep_copy && ts.u.derived->attr.pdt_type)))
9353 tree tmp_var = NULL_TREE;
9356 /* Are the rhs and the lhs the same? */
9359 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9360 gfc_build_addr_expr (NULL_TREE, lse->expr),
9361 gfc_build_addr_expr (NULL_TREE, rse->expr));
9362 cond = gfc_evaluate_now (cond, &lse->pre);
9365 /* Deallocate the lhs allocated components as long as it is not
9366 the same as the rhs. This must be done following the assignment
9367 to prevent deallocating data that could be used in the rhs
9371 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9372 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9374 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9376 gfc_add_expr_to_block (&lse->post, tmp);
9379 gfc_add_block_to_block (&block, &rse->pre);
9380 gfc_add_block_to_block (&block, &lse->pre);
9382 gfc_add_modify (&block, lse->expr,
9383 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9385 /* Restore pointer address of coarray components. */
9386 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9388 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9389 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9391 gfc_add_expr_to_block (&block, tmp);
9394 /* Do a deep copy if the rhs is a variable, if it is not the
9398 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9399 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9400 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9402 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9404 gfc_add_expr_to_block (&block, tmp);
9407 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9409 gfc_add_block_to_block (&block, &lse->pre);
9410 gfc_add_block_to_block (&block, &rse->pre);
9411 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9412 TREE_TYPE (lse->expr), rse->expr);
9413 gfc_add_modify (&block, lse->expr, tmp);
9417 gfc_add_block_to_block (&block, &lse->pre);
9418 gfc_add_block_to_block (&block, &rse->pre);
9420 gfc_add_modify (&block, lse->expr,
9421 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9424 gfc_add_block_to_block (&block, &lse->post);
9425 gfc_add_block_to_block (&block, &rse->post);
9427 return gfc_finish_block (&block);
9431 /* There are quite a lot of restrictions on the optimisation in using an
9432 array function assign without a temporary. */
9435 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9438 bool seen_array_ref;
9440 gfc_symbol *sym = expr1->symtree->n.sym;
9442 /* Play it safe with class functions assigned to a derived type. */
9443 if (gfc_is_class_array_function (expr2)
9444 && expr1->ts.type == BT_DERIVED)
9447 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9448 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9451 /* Elemental functions are scalarized so that they don't need a
9452 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9453 they would need special treatment in gfc_trans_arrayfunc_assign. */
9454 if (expr2->value.function.esym != NULL
9455 && expr2->value.function.esym->attr.elemental)
9458 /* Need a temporary if rhs is not FULL or a contiguous section. */
9459 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9462 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9463 if (gfc_ref_needs_temporary_p (expr1->ref))
9466 /* Functions returning pointers or allocatables need temporaries. */
9467 c = expr2->value.function.esym
9468 ? (expr2->value.function.esym->attr.pointer
9469 || expr2->value.function.esym->attr.allocatable)
9470 : (expr2->symtree->n.sym->attr.pointer
9471 || expr2->symtree->n.sym->attr.allocatable);
9475 /* Character array functions need temporaries unless the
9476 character lengths are the same. */
9477 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9479 if (expr1->ts.u.cl->length == NULL
9480 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9483 if (expr2->ts.u.cl->length == NULL
9484 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9487 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9488 expr2->ts.u.cl->length->value.integer) != 0)
9492 /* Check that no LHS component references appear during an array
9493 reference. This is needed because we do not have the means to
9494 span any arbitrary stride with an array descriptor. This check
9495 is not needed for the rhs because the function result has to be
9497 seen_array_ref = false;
9498 for (ref = expr1->ref; ref; ref = ref->next)
9500 if (ref->type == REF_ARRAY)
9501 seen_array_ref= true;
9502 else if (ref->type == REF_COMPONENT && seen_array_ref)
9506 /* Check for a dependency. */
9507 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9508 expr2->value.function.esym,
9509 expr2->value.function.actual,
9513 /* If we have reached here with an intrinsic function, we do not
9514 need a temporary except in the particular case that reallocation
9515 on assignment is active and the lhs is allocatable and a target. */
9516 if (expr2->value.function.isym)
9517 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9519 /* If the LHS is a dummy, we need a temporary if it is not
9521 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9524 /* If the lhs has been host_associated, is in common, a pointer or is
9525 a target and the function is not using a RESULT variable, aliasing
9526 can occur and a temporary is needed. */
9527 if ((sym->attr.host_assoc
9528 || sym->attr.in_common
9529 || sym->attr.pointer
9530 || sym->attr.cray_pointee
9531 || sym->attr.target)
9532 && expr2->symtree != NULL
9533 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9536 /* A PURE function can unconditionally be called without a temporary. */
9537 if (expr2->value.function.esym != NULL
9538 && expr2->value.function.esym->attr.pure)
9541 /* Implicit_pure functions are those which could legally be declared
9543 if (expr2->value.function.esym != NULL
9544 && expr2->value.function.esym->attr.implicit_pure)
9547 if (!sym->attr.use_assoc
9548 && !sym->attr.in_common
9549 && !sym->attr.pointer
9550 && !sym->attr.target
9551 && !sym->attr.cray_pointee
9552 && expr2->value.function.esym)
9554 /* A temporary is not needed if the function is not contained and
9555 the variable is local or host associated and not a pointer or
9557 if (!expr2->value.function.esym->attr.contained)
9560 /* A temporary is not needed if the lhs has never been host
9561 associated and the procedure is contained. */
9562 else if (!sym->attr.host_assoc)
9565 /* A temporary is not needed if the variable is local and not
9566 a pointer, a target or a result. */
9568 && expr2->value.function.esym->ns == sym->ns->parent)
9572 /* Default to temporary use. */
9577 /* Provide the loop info so that the lhs descriptor can be built for
9578 reallocatable assignments from extrinsic function calls. */
9581 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9584 /* Signal that the function call should not be made by
9585 gfc_conv_loop_setup. */
9586 se->ss->is_alloc_lhs = 1;
9587 gfc_init_loopinfo (loop);
9588 gfc_add_ss_to_loop (loop, *ss);
9589 gfc_add_ss_to_loop (loop, se->ss);
9590 gfc_conv_ss_startstride (loop);
9591 gfc_conv_loop_setup (loop, where);
9592 gfc_copy_loopinfo_to_se (se, loop);
9593 gfc_add_block_to_block (&se->pre, &loop->pre);
9594 gfc_add_block_to_block (&se->pre, &loop->post);
9595 se->ss->is_alloc_lhs = 0;
9599 /* For assignment to a reallocatable lhs from intrinsic functions,
9600 replace the se.expr (ie. the result) with a temporary descriptor.
9601 Null the data field so that the library allocates space for the
9602 result. Free the data of the original descriptor after the function,
9603 in case it appears in an argument expression and transfer the
9604 result to the original descriptor. */
9607 fcncall_realloc_result (gfc_se *se, int rank)
9616 /* Use the allocation done by the library. Substitute the lhs
9617 descriptor with a copy, whose data field is nulled.*/
9618 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9619 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9620 desc = build_fold_indirect_ref_loc (input_location, desc);
9622 /* Unallocated, the descriptor does not have a dtype. */
9623 tmp = gfc_conv_descriptor_dtype (desc);
9624 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9626 res_desc = gfc_evaluate_now (desc, &se->pre);
9627 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9628 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9630 /* Free the lhs after the function call and copy the result data to
9631 the lhs descriptor. */
9632 tmp = gfc_conv_descriptor_data_get (desc);
9633 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9634 logical_type_node, tmp,
9635 build_int_cst (TREE_TYPE (tmp), 0));
9636 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9637 tmp = gfc_call_free (tmp);
9638 gfc_add_expr_to_block (&se->post, tmp);
9640 tmp = gfc_conv_descriptor_data_get (res_desc);
9641 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9643 /* Check that the shapes are the same between lhs and expression. */
9644 for (n = 0 ; n < rank; n++)
9647 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9648 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9649 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9650 gfc_array_index_type, tmp, tmp1);
9651 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9652 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9653 gfc_array_index_type, tmp, tmp1);
9654 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9655 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9656 gfc_array_index_type, tmp, tmp1);
9657 tmp = fold_build2_loc (input_location, NE_EXPR,
9658 logical_type_node, tmp,
9659 gfc_index_zero_node);
9660 tmp = gfc_evaluate_now (tmp, &se->post);
9661 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9662 logical_type_node, tmp,
9666 /* 'zero_cond' being true is equal to lhs not being allocated or the
9667 shapes being different. */
9668 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9670 /* Now reset the bounds returned from the function call to bounds based
9671 on the lhs lbounds, except where the lhs is not allocated or the shapes
9672 of 'variable and 'expr' are different. Set the offset accordingly. */
9673 offset = gfc_index_zero_node;
9674 for (n = 0 ; n < rank; n++)
9678 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9679 lbound = fold_build3_loc (input_location, COND_EXPR,
9680 gfc_array_index_type, zero_cond,
9681 gfc_index_one_node, lbound);
9682 lbound = gfc_evaluate_now (lbound, &se->post);
9684 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9685 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9686 gfc_array_index_type, tmp, lbound);
9687 gfc_conv_descriptor_lbound_set (&se->post, desc,
9688 gfc_rank_cst[n], lbound);
9689 gfc_conv_descriptor_ubound_set (&se->post, desc,
9690 gfc_rank_cst[n], tmp);
9692 /* Set stride and accumulate the offset. */
9693 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9694 gfc_conv_descriptor_stride_set (&se->post, desc,
9695 gfc_rank_cst[n], tmp);
9696 tmp = fold_build2_loc (input_location, MULT_EXPR,
9697 gfc_array_index_type, lbound, tmp);
9698 offset = fold_build2_loc (input_location, MINUS_EXPR,
9699 gfc_array_index_type, offset, tmp);
9700 offset = gfc_evaluate_now (offset, &se->post);
9703 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9708 /* Try to translate array(:) = func (...), where func is a transformational
9709 array function, without using a temporary. Returns NULL if this isn't the
9713 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9717 gfc_component *comp = NULL;
9720 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9723 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9725 comp = gfc_get_proc_ptr_comp (expr2);
9727 if (!(expr2->value.function.isym
9728 || (comp && comp->attr.dimension)
9729 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9730 && expr2->value.function.esym->result->attr.dimension)))
9733 gfc_init_se (&se, NULL);
9734 gfc_start_block (&se.pre);
9735 se.want_pointer = 1;
9737 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9739 if (expr1->ts.type == BT_DERIVED
9740 && expr1->ts.u.derived->attr.alloc_comp)
9743 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9745 gfc_add_expr_to_block (&se.pre, tmp);
9748 se.direct_byref = 1;
9749 se.ss = gfc_walk_expr (expr2);
9750 gcc_assert (se.ss != gfc_ss_terminator);
9752 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9753 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9754 Clearly, this cannot be done for an allocatable function result, since
9755 the shape of the result is unknown and, in any case, the function must
9756 correctly take care of the reallocation internally. For intrinsic
9757 calls, the array data is freed and the library takes care of allocation.
9758 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9760 if (flag_realloc_lhs
9761 && gfc_is_reallocatable_lhs (expr1)
9762 && !gfc_expr_attr (expr1).codimension
9763 && !gfc_is_coindexed (expr1)
9764 && !(expr2->value.function.esym
9765 && expr2->value.function.esym->result->attr.allocatable))
9767 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9769 if (!expr2->value.function.isym)
9771 ss = gfc_walk_expr (expr1);
9772 gcc_assert (ss != gfc_ss_terminator);
9774 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9775 ss->is_alloc_lhs = 1;
9778 fcncall_realloc_result (&se, expr1->rank);
9781 gfc_conv_function_expr (&se, expr2);
9782 gfc_add_block_to_block (&se.pre, &se.post);
9785 gfc_cleanup_loop (&loop);
9787 gfc_free_ss_chain (se.ss);
9789 return gfc_finish_block (&se.pre);
9793 /* Try to efficiently translate array(:) = 0. Return NULL if this
9797 gfc_trans_zero_assign (gfc_expr * expr)
9799 tree dest, len, type;
9803 sym = expr->symtree->n.sym;
9804 dest = gfc_get_symbol_decl (sym);
9806 type = TREE_TYPE (dest);
9807 if (POINTER_TYPE_P (type))
9808 type = TREE_TYPE (type);
9809 if (!GFC_ARRAY_TYPE_P (type))
9812 /* Determine the length of the array. */
9813 len = GFC_TYPE_ARRAY_SIZE (type);
9814 if (!len || TREE_CODE (len) != INTEGER_CST)
9817 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9818 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9819 fold_convert (gfc_array_index_type, tmp));
9821 /* If we are zeroing a local array avoid taking its address by emitting
9823 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9824 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9825 dest, build_constructor (TREE_TYPE (dest),
9828 /* Convert arguments to the correct types. */
9829 dest = fold_convert (pvoid_type_node, dest);
9830 len = fold_convert (size_type_node, len);
9832 /* Construct call to __builtin_memset. */
9833 tmp = build_call_expr_loc (input_location,
9834 builtin_decl_explicit (BUILT_IN_MEMSET),
9835 3, dest, integer_zero_node, len);
9836 return fold_convert (void_type_node, tmp);
9840 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9841 that constructs the call to __builtin_memcpy. */
9844 gfc_build_memcpy_call (tree dst, tree src, tree len)
9848 /* Convert arguments to the correct types. */
9849 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9850 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9852 dst = fold_convert (pvoid_type_node, dst);
9854 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9855 src = gfc_build_addr_expr (pvoid_type_node, src);
9857 src = fold_convert (pvoid_type_node, src);
9859 len = fold_convert (size_type_node, len);
9861 /* Construct call to __builtin_memcpy. */
9862 tmp = build_call_expr_loc (input_location,
9863 builtin_decl_explicit (BUILT_IN_MEMCPY),
9865 return fold_convert (void_type_node, tmp);
9869 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9870 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9871 source/rhs, both are gfc_full_array_ref_p which have been checked for
9875 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9877 tree dst, dlen, dtype;
9878 tree src, slen, stype;
9881 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9882 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9884 dtype = TREE_TYPE (dst);
9885 if (POINTER_TYPE_P (dtype))
9886 dtype = TREE_TYPE (dtype);
9887 stype = TREE_TYPE (src);
9888 if (POINTER_TYPE_P (stype))
9889 stype = TREE_TYPE (stype);
9891 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9894 /* Determine the lengths of the arrays. */
9895 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9896 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9898 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9899 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9900 dlen, fold_convert (gfc_array_index_type, tmp));
9902 slen = GFC_TYPE_ARRAY_SIZE (stype);
9903 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9905 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9906 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9907 slen, fold_convert (gfc_array_index_type, tmp));
9909 /* Sanity check that they are the same. This should always be
9910 the case, as we should already have checked for conformance. */
9911 if (!tree_int_cst_equal (slen, dlen))
9914 return gfc_build_memcpy_call (dst, src, dlen);
9918 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9919 this can't be done. EXPR1 is the destination/lhs for which
9920 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9923 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9925 unsigned HOST_WIDE_INT nelem;
9931 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9935 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9936 dtype = TREE_TYPE (dst);
9937 if (POINTER_TYPE_P (dtype))
9938 dtype = TREE_TYPE (dtype);
9939 if (!GFC_ARRAY_TYPE_P (dtype))
9942 /* Determine the lengths of the array. */
9943 len = GFC_TYPE_ARRAY_SIZE (dtype);
9944 if (!len || TREE_CODE (len) != INTEGER_CST)
9947 /* Confirm that the constructor is the same size. */
9948 if (compare_tree_int (len, nelem) != 0)
9951 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9952 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9953 fold_convert (gfc_array_index_type, tmp));
9955 stype = gfc_typenode_for_spec (&expr2->ts);
9956 src = gfc_build_constant_array_constructor (expr2, stype);
9958 stype = TREE_TYPE (src);
9959 if (POINTER_TYPE_P (stype))
9960 stype = TREE_TYPE (stype);
9962 return gfc_build_memcpy_call (dst, src, len);
9966 /* Tells whether the expression is to be treated as a variable reference. */
9969 gfc_expr_is_variable (gfc_expr *expr)
9972 gfc_component *comp;
9973 gfc_symbol *func_ifc;
9975 if (expr->expr_type == EXPR_VARIABLE)
9978 arg = gfc_get_noncopying_intrinsic_argument (expr);
9981 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9982 return gfc_expr_is_variable (arg);
9985 /* A data-pointer-returning function should be considered as a variable
9987 if (expr->expr_type == EXPR_FUNCTION
9988 && expr->ref == NULL)
9990 if (expr->value.function.isym != NULL)
9993 if (expr->value.function.esym != NULL)
9995 func_ifc = expr->value.function.esym;
10000 gcc_assert (expr->symtree);
10001 func_ifc = expr->symtree->n.sym;
10005 gcc_unreachable ();
10008 comp = gfc_get_proc_ptr_comp (expr);
10009 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10012 func_ifc = comp->ts.interface;
10016 if (expr->expr_type == EXPR_COMPCALL)
10018 gcc_assert (!expr->value.compcall.tbp->is_generic);
10019 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10026 gcc_assert (func_ifc->attr.function
10027 && func_ifc->result != NULL);
10028 return func_ifc->result->attr.pointer;
10032 /* Is the lhs OK for automatic reallocation? */
10035 is_scalar_reallocatable_lhs (gfc_expr *expr)
10039 /* An allocatable variable with no reference. */
10040 if (expr->symtree->n.sym->attr.allocatable
10044 /* All that can be left are allocatable components. However, we do
10045 not check for allocatable components here because the expression
10046 could be an allocatable component of a pointer component. */
10047 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10048 && expr->symtree->n.sym->ts.type != BT_CLASS)
10051 /* Find an allocatable component ref last. */
10052 for (ref = expr->ref; ref; ref = ref->next)
10053 if (ref->type == REF_COMPONENT
10055 && ref->u.c.component->attr.allocatable)
10062 /* Allocate or reallocate scalar lhs, as necessary. */
10065 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10066 tree string_length,
10074 tree size_in_bytes;
10080 if (!expr1 || expr1->rank)
10083 if (!expr2 || expr2->rank)
10086 for (ref = expr1->ref; ref; ref = ref->next)
10087 if (ref->type == REF_SUBSTRING)
10090 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10092 /* Since this is a scalar lhs, we can afford to do this. That is,
10093 there is no risk of side effects being repeated. */
10094 gfc_init_se (&lse, NULL);
10095 lse.want_pointer = 1;
10096 gfc_conv_expr (&lse, expr1);
10098 jump_label1 = gfc_build_label_decl (NULL_TREE);
10099 jump_label2 = gfc_build_label_decl (NULL_TREE);
10101 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10102 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10103 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10105 tmp = build3_v (COND_EXPR, cond,
10106 build1_v (GOTO_EXPR, jump_label1),
10107 build_empty_stmt (input_location));
10108 gfc_add_expr_to_block (block, tmp);
10110 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10112 /* Use the rhs string length and the lhs element size. */
10113 size = string_length;
10114 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10115 tmp = TYPE_SIZE_UNIT (tmp);
10116 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10117 TREE_TYPE (tmp), tmp,
10118 fold_convert (TREE_TYPE (tmp), size));
10122 /* Otherwise use the length in bytes of the rhs. */
10123 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10124 size_in_bytes = size;
10127 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10128 size_in_bytes, size_one_node);
10130 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10132 tree caf_decl, token;
10134 symbol_attribute attr;
10136 gfc_clear_attr (&attr);
10137 gfc_init_se (&caf_se, NULL);
10139 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10140 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10142 gfc_add_block_to_block (block, &caf_se.pre);
10143 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10144 gfc_build_addr_expr (NULL_TREE, token),
10145 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10148 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10150 tmp = build_call_expr_loc (input_location,
10151 builtin_decl_explicit (BUILT_IN_CALLOC),
10152 2, build_one_cst (size_type_node),
10154 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10155 gfc_add_modify (block, lse.expr, tmp);
10159 tmp = build_call_expr_loc (input_location,
10160 builtin_decl_explicit (BUILT_IN_MALLOC),
10162 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10163 gfc_add_modify (block, lse.expr, tmp);
10166 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10168 /* Deferred characters need checking for lhs and rhs string
10169 length. Other deferred parameter variables will have to
10171 tmp = build1_v (GOTO_EXPR, jump_label2);
10172 gfc_add_expr_to_block (block, tmp);
10174 tmp = build1_v (LABEL_EXPR, jump_label1);
10175 gfc_add_expr_to_block (block, tmp);
10177 /* For a deferred length character, reallocate if lengths of lhs and
10178 rhs are different. */
10179 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10181 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10183 fold_convert (TREE_TYPE (lse.string_length),
10185 /* Jump past the realloc if the lengths are the same. */
10186 tmp = build3_v (COND_EXPR, cond,
10187 build1_v (GOTO_EXPR, jump_label2),
10188 build_empty_stmt (input_location));
10189 gfc_add_expr_to_block (block, tmp);
10190 tmp = build_call_expr_loc (input_location,
10191 builtin_decl_explicit (BUILT_IN_REALLOC),
10192 2, fold_convert (pvoid_type_node, lse.expr),
10194 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10195 gfc_add_modify (block, lse.expr, tmp);
10196 tmp = build1_v (LABEL_EXPR, jump_label2);
10197 gfc_add_expr_to_block (block, tmp);
10199 /* Update the lhs character length. */
10200 size = string_length;
10201 gfc_add_modify (block, lse.string_length,
10202 fold_convert (TREE_TYPE (lse.string_length), size));
10206 /* Check for assignments of the type
10210 to make sure we do not check for reallocation unneccessarily. */
10214 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10216 gfc_actual_arglist *a;
10219 switch (expr2->expr_type)
10221 case EXPR_VARIABLE:
10222 return gfc_dep_compare_expr (expr1, expr2) == 0;
10224 case EXPR_FUNCTION:
10225 if (expr2->value.function.esym
10226 && expr2->value.function.esym->attr.elemental)
10228 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10231 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10236 else if (expr2->value.function.isym
10237 && expr2->value.function.isym->elemental)
10239 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10242 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10251 switch (expr2->value.op.op)
10253 case INTRINSIC_NOT:
10254 case INTRINSIC_UPLUS:
10255 case INTRINSIC_UMINUS:
10256 case INTRINSIC_PARENTHESES:
10257 return is_runtime_conformable (expr1, expr2->value.op.op1);
10259 case INTRINSIC_PLUS:
10260 case INTRINSIC_MINUS:
10261 case INTRINSIC_TIMES:
10262 case INTRINSIC_DIVIDE:
10263 case INTRINSIC_POWER:
10264 case INTRINSIC_AND:
10266 case INTRINSIC_EQV:
10267 case INTRINSIC_NEQV:
10274 case INTRINSIC_EQ_OS:
10275 case INTRINSIC_NE_OS:
10276 case INTRINSIC_GT_OS:
10277 case INTRINSIC_GE_OS:
10278 case INTRINSIC_LT_OS:
10279 case INTRINSIC_LE_OS:
10281 e1 = expr2->value.op.op1;
10282 e2 = expr2->value.op.op2;
10284 if (e1->rank == 0 && e2->rank > 0)
10285 return is_runtime_conformable (expr1, e2);
10286 else if (e1->rank > 0 && e2->rank == 0)
10287 return is_runtime_conformable (expr1, e1);
10288 else if (e1->rank > 0 && e2->rank > 0)
10289 return is_runtime_conformable (expr1, e1)
10290 && is_runtime_conformable (expr1, e2);
10308 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10309 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10310 bool class_realloc)
10312 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10313 vec<tree, va_gc> *args = NULL;
10315 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10318 /* Generate allocation of the lhs. */
10324 tmp = gfc_vptr_size_get (vptr);
10325 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10326 ? gfc_class_data_get (lse->expr) : lse->expr;
10327 gfc_init_block (&alloc);
10328 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10329 tmp = fold_build2_loc (input_location, EQ_EXPR,
10330 logical_type_node, class_han,
10331 build_int_cst (prvoid_type_node, 0));
10332 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10334 PRED_FORTRAN_FAIL_ALLOC),
10335 gfc_finish_block (&alloc),
10336 build_empty_stmt (input_location));
10337 gfc_add_expr_to_block (&lse->pre, tmp);
10340 fcn = gfc_vptr_copy_get (vptr);
10342 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10343 ? gfc_class_data_get (rse->expr) : rse->expr;
10346 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10347 || INDIRECT_REF_P (tmp)
10348 || (rhs->ts.type == BT_DERIVED
10349 && rhs->ts.u.derived->attr.unlimited_polymorphic
10350 && !rhs->ts.u.derived->attr.pointer
10351 && !rhs->ts.u.derived->attr.allocatable)
10352 || (UNLIMITED_POLY (rhs)
10353 && !CLASS_DATA (rhs)->attr.pointer
10354 && !CLASS_DATA (rhs)->attr.allocatable))
10355 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10357 vec_safe_push (args, tmp);
10358 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10359 ? gfc_class_data_get (lse->expr) : lse->expr;
10360 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10361 || INDIRECT_REF_P (tmp)
10362 || (lhs->ts.type == BT_DERIVED
10363 && lhs->ts.u.derived->attr.unlimited_polymorphic
10364 && !lhs->ts.u.derived->attr.pointer
10365 && !lhs->ts.u.derived->attr.allocatable)
10366 || (UNLIMITED_POLY (lhs)
10367 && !CLASS_DATA (lhs)->attr.pointer
10368 && !CLASS_DATA (lhs)->attr.allocatable))
10369 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10371 vec_safe_push (args, tmp);
10373 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10375 if (to_len != NULL_TREE && !integer_zerop (from_len))
10378 vec_safe_push (args, from_len);
10379 vec_safe_push (args, to_len);
10380 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10382 tmp = fold_build2_loc (input_location, GT_EXPR,
10383 logical_type_node, from_len,
10384 build_zero_cst (TREE_TYPE (from_len)));
10385 return fold_build3_loc (input_location, COND_EXPR,
10386 void_type_node, tmp,
10394 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10395 ? gfc_class_data_get (lse->expr) : lse->expr;
10396 stmtblock_t tblock;
10397 gfc_init_block (&tblock);
10398 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10399 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10400 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10401 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10402 /* When coming from a ptr_copy lhs and rhs are swapped. */
10403 gfc_add_modify_loc (input_location, &tblock, rhst,
10404 fold_convert (TREE_TYPE (rhst), tmp));
10405 return gfc_finish_block (&tblock);
10409 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10410 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10411 init_flag indicates initialization expressions and dealloc that no
10412 deallocate prior assignment is needed (if in doubt, set true).
10413 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10414 routine instead of a pointer assignment. Alias resolution is only done,
10415 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10416 where it is known, that newly allocated memory on the lhs can never be
10417 an alias of the rhs. */
10420 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10421 bool dealloc, bool use_vptr_copy, bool may_alias)
10426 gfc_ss *lss_section;
10433 bool scalar_to_array;
10434 tree string_length;
10436 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10437 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10438 bool is_poly_assign;
10440 /* Assignment of the form lhs = rhs. */
10441 gfc_start_block (&block);
10443 gfc_init_se (&lse, NULL);
10444 gfc_init_se (&rse, NULL);
10446 /* Walk the lhs. */
10447 lss = gfc_walk_expr (expr1);
10448 if (gfc_is_reallocatable_lhs (expr1))
10450 lss->no_bounds_check = 1;
10451 if (!(expr2->expr_type == EXPR_FUNCTION
10452 && expr2->value.function.isym != NULL
10453 && !(expr2->value.function.isym->elemental
10454 || expr2->value.function.isym->conversion)))
10455 lss->is_alloc_lhs = 1;
10458 lss->no_bounds_check = expr1->no_bounds_check;
10462 if ((expr1->ts.type == BT_DERIVED)
10463 && (gfc_is_class_array_function (expr2)
10464 || gfc_is_alloc_class_scalar_function (expr2)))
10465 expr2->must_finalize = 1;
10467 /* Checking whether a class assignment is desired is quite complicated and
10468 needed at two locations, so do it once only before the information is
10470 lhs_attr = gfc_expr_attr (expr1);
10471 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10472 || (lhs_attr.allocatable && !lhs_attr.dimension))
10473 && (expr1->ts.type == BT_CLASS
10474 || gfc_is_class_array_ref (expr1, NULL)
10475 || gfc_is_class_scalar_expr (expr1)
10476 || gfc_is_class_array_ref (expr2, NULL)
10477 || gfc_is_class_scalar_expr (expr2));
10480 /* Only analyze the expressions for coarray properties, when in coarray-lib
10482 if (flag_coarray == GFC_FCOARRAY_LIB)
10484 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10485 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10488 if (lss != gfc_ss_terminator)
10490 /* The assignment needs scalarization. */
10493 /* Find a non-scalar SS from the lhs. */
10494 while (lss_section != gfc_ss_terminator
10495 && lss_section->info->type != GFC_SS_SECTION)
10496 lss_section = lss_section->next;
10498 gcc_assert (lss_section != gfc_ss_terminator);
10500 /* Initialize the scalarizer. */
10501 gfc_init_loopinfo (&loop);
10503 /* Walk the rhs. */
10504 rss = gfc_walk_expr (expr2);
10505 if (rss == gfc_ss_terminator)
10506 /* The rhs is scalar. Add a ss for the expression. */
10507 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10508 /* When doing a class assign, then the handle to the rhs needs to be a
10509 pointer to allow for polymorphism. */
10510 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10511 rss->info->type = GFC_SS_REFERENCE;
10513 rss->no_bounds_check = expr2->no_bounds_check;
10514 /* Associate the SS with the loop. */
10515 gfc_add_ss_to_loop (&loop, lss);
10516 gfc_add_ss_to_loop (&loop, rss);
10518 /* Calculate the bounds of the scalarization. */
10519 gfc_conv_ss_startstride (&loop);
10520 /* Enable loop reversal. */
10521 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10522 loop.reverse[n] = GFC_ENABLE_REVERSE;
10523 /* Resolve any data dependencies in the statement. */
10525 gfc_conv_resolve_dependencies (&loop, lss, rss);
10526 /* Setup the scalarizing loops. */
10527 gfc_conv_loop_setup (&loop, &expr2->where);
10529 /* Setup the gfc_se structures. */
10530 gfc_copy_loopinfo_to_se (&lse, &loop);
10531 gfc_copy_loopinfo_to_se (&rse, &loop);
10534 gfc_mark_ss_chain_used (rss, 1);
10535 if (loop.temp_ss == NULL)
10538 gfc_mark_ss_chain_used (lss, 1);
10542 lse.ss = loop.temp_ss;
10543 gfc_mark_ss_chain_used (lss, 3);
10544 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10547 /* Allow the scalarizer to workshare array assignments. */
10548 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10549 == OMPWS_WORKSHARE_FLAG
10550 && loop.temp_ss == NULL)
10552 maybe_workshare = true;
10553 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10556 /* Start the scalarized loop body. */
10557 gfc_start_scalarized_body (&loop, &body);
10560 gfc_init_block (&body);
10562 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10564 /* Translate the expression. */
10565 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10566 && lhs_caf_attr.codimension;
10567 gfc_conv_expr (&rse, expr2);
10569 /* Deal with the case of a scalar class function assigned to a derived type. */
10570 if (gfc_is_alloc_class_scalar_function (expr2)
10571 && expr1->ts.type == BT_DERIVED)
10573 rse.expr = gfc_class_data_get (rse.expr);
10574 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10577 /* Stabilize a string length for temporaries. */
10578 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10579 && !(VAR_P (rse.string_length)
10580 || TREE_CODE (rse.string_length) == PARM_DECL
10581 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10582 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10583 else if (expr2->ts.type == BT_CHARACTER)
10585 if (expr1->ts.deferred
10586 && gfc_expr_attr (expr1).allocatable
10587 && gfc_check_dependency (expr1, expr2, true))
10588 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10589 string_length = rse.string_length;
10592 string_length = NULL_TREE;
10596 gfc_conv_tmp_array_ref (&lse);
10597 if (expr2->ts.type == BT_CHARACTER)
10598 lse.string_length = string_length;
10602 gfc_conv_expr (&lse, expr1);
10603 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10605 && gfc_expr_attr (expr1).allocatable
10612 tmp = INDIRECT_REF_P (lse.expr)
10613 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10615 /* We should only get array references here. */
10616 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10617 || TREE_CODE (tmp) == ARRAY_REF);
10619 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10620 or the array itself(ARRAY_REF). */
10621 tmp = TREE_OPERAND (tmp, 0);
10623 /* Provide the address of the array. */
10624 if (TREE_CODE (lse.expr) == ARRAY_REF)
10625 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10627 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10628 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10629 msg = _("Assignment of scalar to unallocated array");
10630 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10631 &expr1->where, msg);
10634 /* Deallocate the lhs parameterized components if required. */
10635 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10636 && !expr1->symtree->n.sym->attr.associate_var)
10638 if (expr1->ts.type == BT_DERIVED
10639 && expr1->ts.u.derived
10640 && expr1->ts.u.derived->attr.pdt_type)
10642 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10644 gfc_add_expr_to_block (&lse.pre, tmp);
10646 else if (expr1->ts.type == BT_CLASS
10647 && CLASS_DATA (expr1)->ts.u.derived
10648 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10650 tmp = gfc_class_data_get (lse.expr);
10651 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10653 gfc_add_expr_to_block (&lse.pre, tmp);
10658 /* Assignments of scalar derived types with allocatable components
10659 to arrays must be done with a deep copy and the rhs temporary
10660 must have its components deallocated afterwards. */
10661 scalar_to_array = (expr2->ts.type == BT_DERIVED
10662 && expr2->ts.u.derived->attr.alloc_comp
10663 && !gfc_expr_is_variable (expr2)
10664 && expr1->rank && !expr2->rank);
10665 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10667 && expr1->ts.u.derived->attr.alloc_comp
10668 && gfc_is_alloc_class_scalar_function (expr2));
10669 if (scalar_to_array && dealloc)
10671 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10672 gfc_prepend_expr_to_block (&loop.post, tmp);
10675 /* When assigning a character function result to a deferred-length variable,
10676 the function call must happen before the (re)allocation of the lhs -
10677 otherwise the character length of the result is not known.
10678 NOTE 1: This relies on having the exact dependence of the length type
10679 parameter available to the caller; gfortran saves it in the .mod files.
10680 NOTE 2: Vector array references generate an index temporary that must
10681 not go outside the loop. Otherwise, variables should not generate
10683 NOTE 3: The concatenation operation generates a temporary pointer,
10684 whose allocation must go to the innermost loop.
10685 NOTE 4: Elemental functions may generate a temporary, too. */
10686 if (flag_realloc_lhs
10687 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10688 && !(lss != gfc_ss_terminator
10689 && rss != gfc_ss_terminator
10690 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10691 || (expr2->expr_type == EXPR_FUNCTION
10692 && expr2->value.function.esym != NULL
10693 && expr2->value.function.esym->attr.elemental)
10694 || (expr2->expr_type == EXPR_FUNCTION
10695 && expr2->value.function.isym != NULL
10696 && expr2->value.function.isym->elemental)
10697 || (expr2->expr_type == EXPR_OP
10698 && expr2->value.op.op == INTRINSIC_CONCAT))))
10699 gfc_add_block_to_block (&block, &rse.pre);
10701 /* Nullify the allocatable components corresponding to those of the lhs
10702 derived type, so that the finalization of the function result does not
10703 affect the lhs of the assignment. Prepend is used to ensure that the
10704 nullification occurs before the call to the finalizer. In the case of
10705 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10706 as part of the deep copy. */
10707 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10708 && (gfc_is_class_array_function (expr2)
10709 || gfc_is_alloc_class_scalar_function (expr2)))
10712 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10713 gfc_prepend_expr_to_block (&rse.post, tmp);
10714 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10715 gfc_add_block_to_block (&loop.post, &rse.post);
10720 if (is_poly_assign)
10721 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10722 use_vptr_copy || (lhs_attr.allocatable
10723 && !lhs_attr.dimension),
10724 flag_realloc_lhs && !lhs_attr.pointer);
10725 else if (flag_coarray == GFC_FCOARRAY_LIB
10726 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10727 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10728 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10730 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10731 allocatable component, because those need to be accessed via the
10732 caf-runtime. No need to check for coindexes here, because resolve
10733 has rewritten those already. */
10735 gfc_actual_arglist a1, a2;
10736 /* Clear the structures to prevent accessing garbage. */
10737 memset (&code, '\0', sizeof (gfc_code));
10738 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10739 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10744 code.ext.actual = &a1;
10745 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10746 tmp = gfc_conv_intrinsic_subroutine (&code);
10748 else if (!is_poly_assign && expr2->must_finalize
10749 && expr1->ts.type == BT_CLASS
10750 && expr2->ts.type == BT_CLASS)
10752 /* This case comes about when the scalarizer provides array element
10753 references. Use the vptr copy function, since this does a deep
10754 copy of allocatable components, without which the finalizer call */
10755 tmp = gfc_get_vptr_from_expr (rse.expr);
10756 if (tmp != NULL_TREE)
10758 tree fcn = gfc_vptr_copy_get (tmp);
10759 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10760 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10761 tmp = build_call_expr_loc (input_location,
10763 gfc_build_addr_expr (NULL, rse.expr),
10764 gfc_build_addr_expr (NULL, lse.expr));
10768 /* If nothing else works, do it the old fashioned way! */
10769 if (tmp == NULL_TREE)
10770 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10771 gfc_expr_is_variable (expr2)
10773 || expr2->expr_type == EXPR_ARRAY,
10774 !(l_is_temp || init_flag) && dealloc,
10775 expr1->symtree->n.sym->attr.codimension);
10777 /* Add the pre blocks to the body. */
10778 gfc_add_block_to_block (&body, &rse.pre);
10779 gfc_add_block_to_block (&body, &lse.pre);
10780 gfc_add_expr_to_block (&body, tmp);
10781 /* Add the post blocks to the body. */
10782 gfc_add_block_to_block (&body, &rse.post);
10783 gfc_add_block_to_block (&body, &lse.post);
10785 if (lss == gfc_ss_terminator)
10787 /* F2003: Add the code for reallocation on assignment. */
10788 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10789 && !is_poly_assign)
10790 alloc_scalar_allocatable_for_assignment (&block, string_length,
10793 /* Use the scalar assignment as is. */
10794 gfc_add_block_to_block (&block, &body);
10798 gcc_assert (lse.ss == gfc_ss_terminator
10799 && rse.ss == gfc_ss_terminator);
10803 gfc_trans_scalarized_loop_boundary (&loop, &body);
10805 /* We need to copy the temporary to the actual lhs. */
10806 gfc_init_se (&lse, NULL);
10807 gfc_init_se (&rse, NULL);
10808 gfc_copy_loopinfo_to_se (&lse, &loop);
10809 gfc_copy_loopinfo_to_se (&rse, &loop);
10811 rse.ss = loop.temp_ss;
10814 gfc_conv_tmp_array_ref (&rse);
10815 gfc_conv_expr (&lse, expr1);
10817 gcc_assert (lse.ss == gfc_ss_terminator
10818 && rse.ss == gfc_ss_terminator);
10820 if (expr2->ts.type == BT_CHARACTER)
10821 rse.string_length = string_length;
10823 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10825 gfc_add_expr_to_block (&body, tmp);
10828 /* F2003: Allocate or reallocate lhs of allocatable array. */
10829 if (flag_realloc_lhs
10830 && gfc_is_reallocatable_lhs (expr1)
10832 && !is_runtime_conformable (expr1, expr2))
10834 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10835 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10836 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10837 if (tmp != NULL_TREE)
10838 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10841 if (maybe_workshare)
10842 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10844 /* Generate the copying loops. */
10845 gfc_trans_scalarizing_loops (&loop, &body);
10847 /* Wrap the whole thing up. */
10848 gfc_add_block_to_block (&block, &loop.pre);
10849 gfc_add_block_to_block (&block, &loop.post);
10851 gfc_cleanup_loop (&loop);
10854 return gfc_finish_block (&block);
10858 /* Check whether EXPR is a copyable array. */
10861 copyable_array_p (gfc_expr * expr)
10863 if (expr->expr_type != EXPR_VARIABLE)
10866 /* First check it's an array. */
10867 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10870 if (!gfc_full_array_ref_p (expr->ref, NULL))
10873 /* Next check that it's of a simple enough type. */
10874 switch (expr->ts.type)
10886 return !expr->ts.u.derived->attr.alloc_comp;
10895 /* Translate an assignment. */
10898 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10899 bool dealloc, bool use_vptr_copy, bool may_alias)
10903 /* Special case a single function returning an array. */
10904 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10906 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10911 /* Special case assigning an array to zero. */
10912 if (copyable_array_p (expr1)
10913 && is_zero_initializer_p (expr2))
10915 tmp = gfc_trans_zero_assign (expr1);
10920 /* Special case copying one array to another. */
10921 if (copyable_array_p (expr1)
10922 && copyable_array_p (expr2)
10923 && gfc_compare_types (&expr1->ts, &expr2->ts)
10924 && !gfc_check_dependency (expr1, expr2, 0))
10926 tmp = gfc_trans_array_copy (expr1, expr2);
10931 /* Special case initializing an array from a constant array constructor. */
10932 if (copyable_array_p (expr1)
10933 && expr2->expr_type == EXPR_ARRAY
10934 && gfc_compare_types (&expr1->ts, &expr2->ts))
10936 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10941 if (UNLIMITED_POLY (expr1) && expr1->rank
10942 && expr2->ts.type != BT_CLASS)
10943 use_vptr_copy = true;
10945 /* Fallback to the scalarizer to generate explicit loops. */
10946 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10947 use_vptr_copy, may_alias);
10951 gfc_trans_init_assign (gfc_code * code)
10953 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10957 gfc_trans_assign (gfc_code * code)
10959 return gfc_trans_assignment (code->expr1, code->expr2, false, true);