1 /* Expression translation
2 Copyright (C) 2002-2021 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
);
261 gfc_resize_class_size_with_len (stmtblock_t
* block
, tree class_expr
, tree size
)
267 tmp
= gfc_class_len_or_zero_get (class_expr
);
269 /* Include the len value in the element size if present. */
270 if (!integer_zerop (tmp
))
272 type
= TREE_TYPE (size
);
275 size
= gfc_evaluate_now (size
, block
);
276 tmp
= gfc_evaluate_now (fold_convert (type
, tmp
), block
);
278 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
280 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
281 logical_type_node
, tmp
,
282 build_zero_cst (type
));
283 size
= fold_build3_loc (input_location
, COND_EXPR
,
284 type
, tmp
, tmp2
, size
);
290 size
= gfc_evaluate_now (size
, block
);
296 /* Get the specified FIELD from the VPTR. */
299 vptr_field_get (tree vptr
, int fieldno
)
302 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
303 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
305 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
306 TREE_TYPE (field
), vptr
, field
,
313 /* Get the field from the class' vptr. */
316 class_vtab_field_get (tree decl
, int fieldno
)
319 vptr
= gfc_class_vptr_get (decl
);
320 return vptr_field_get (vptr
, fieldno
);
324 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
326 #define VTAB_GET_FIELD_GEN(name, field) tree \
327 gfc_class_vtab_## name ##_get (tree cl) \
329 return class_vtab_field_get (cl, field); \
333 gfc_vptr_## name ##_get (tree vptr) \
335 return vptr_field_get (vptr, field); \
338 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
339 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
340 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
341 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
342 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
343 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
346 /* The size field is returned as an array index type. Therefore treat
347 it and only it specially. */
350 gfc_class_vtab_size_get (tree cl
)
353 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
354 /* Always return size as an array index type. */
355 size
= fold_convert (gfc_array_index_type
, size
);
361 gfc_vptr_size_get (tree vptr
)
364 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
365 /* Always return size as an array index type. */
366 size
= fold_convert (gfc_array_index_type
, size
);
372 #undef CLASS_DATA_FIELD
373 #undef CLASS_VPTR_FIELD
374 #undef CLASS_LEN_FIELD
375 #undef VTABLE_HASH_FIELD
376 #undef VTABLE_SIZE_FIELD
377 #undef VTABLE_EXTENDS_FIELD
378 #undef VTABLE_DEF_INIT_FIELD
379 #undef VTABLE_COPY_FIELD
380 #undef VTABLE_FINAL_FIELD
383 /* Search for the last _class ref in the chain of references of this
384 expression and cut the chain there. Albeit this routine is similiar
385 to class.c::gfc_add_component_ref (), is there a significant
386 difference: gfc_add_component_ref () concentrates on an array ref to
387 be the last ref in the chain. This routine is oblivious to the kind
388 of refs following. */
391 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
, bool is_mold
)
394 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
396 /* Find the last class reference. */
399 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
401 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
404 if (ref
->type
== REF_COMPONENT
405 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
407 /* Component to the right of a part reference with nonzero rank
408 must not have the ALLOCATABLE attribute. If attempts are
409 made to reference such a component reference, an error results
410 followed by an ICE. */
411 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
416 if (ref
->next
== NULL
)
420 /* Remove and store all subsequent references after the
424 tail
= class_ref
->next
;
425 class_ref
->next
= NULL
;
427 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
434 base_expr
= gfc_expr_to_initialize (e
);
436 base_expr
= gfc_copy_expr (e
);
438 /* Restore the original tail expression. */
441 gfc_free_ref_list (class_ref
->next
);
442 class_ref
->next
= tail
;
444 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
446 gfc_free_ref_list (e
->ref
);
453 /* Reset the vptr to the declared type, e.g. after deallocation. */
456 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
463 /* Evaluate the expression and obtain the vptr from it. */
464 gfc_init_se (&se
, NULL
);
466 gfc_conv_expr_descriptor (&se
, e
);
468 gfc_conv_expr (&se
, e
);
469 gfc_add_block_to_block (block
, &se
.pre
);
470 vptr
= gfc_get_vptr_from_expr (se
.expr
);
472 /* If a vptr is not found, we can do nothing more. */
473 if (vptr
== NULL_TREE
)
476 if (UNLIMITED_POLY (e
))
477 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
480 /* Return the vptr to the address of the declared type. */
481 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
482 vtable
= vtab
->backend_decl
;
483 if (vtable
== NULL_TREE
)
484 vtable
= gfc_get_symbol_decl (vtab
);
485 vtable
= gfc_build_addr_expr (NULL
, vtable
);
486 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
487 gfc_add_modify (block
, vptr
, vtable
);
492 /* Reset the len for unlimited polymorphic objects. */
495 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
499 e
= gfc_find_and_cut_at_last_class_ref (expr
);
502 gfc_add_len_component (e
);
503 gfc_init_se (&se_len
, NULL
);
504 gfc_conv_expr (&se_len
, e
);
505 gfc_add_modify (block
, se_len
.expr
,
506 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
511 /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
512 reference is found. Note that it is up to the caller to avoid using this
513 for expressions other than variables. */
516 gfc_get_class_from_gfc_expr (gfc_expr
*e
)
518 gfc_expr
*class_expr
;
520 class_expr
= gfc_find_and_cut_at_last_class_ref (e
);
521 if (class_expr
== NULL
)
523 gfc_init_se (&cse
, NULL
);
524 gfc_conv_expr (&cse
, class_expr
);
525 gfc_free_expr (class_expr
);
530 /* Obtain the last class reference in an expression.
531 Return NULL_TREE if no class reference is found. */
534 gfc_get_class_from_expr (tree expr
)
539 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
541 if (CONSTANT_CLASS_P (tmp
))
544 type
= TREE_TYPE (tmp
);
547 if (GFC_CLASS_TYPE_P (type
))
549 if (type
!= TYPE_CANONICAL (type
))
550 type
= TYPE_CANONICAL (type
);
554 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
558 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
559 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
561 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
568 /* Obtain the vptr of the last class reference in an expression.
569 Return NULL_TREE if no class reference is found. */
572 gfc_get_vptr_from_expr (tree expr
)
576 tmp
= gfc_get_class_from_expr (expr
);
578 if (tmp
!= NULL_TREE
)
579 return gfc_class_vptr_get (tmp
);
586 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
589 tree tmp
, tmp2
, type
;
591 gfc_conv_descriptor_data_set (block
, lhs_desc
,
592 gfc_conv_descriptor_data_get (rhs_desc
));
593 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
594 gfc_conv_descriptor_offset_get (rhs_desc
));
596 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
597 gfc_conv_descriptor_dtype (rhs_desc
));
599 /* Assign the dimension as range-ref. */
600 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
601 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
603 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
604 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
605 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
606 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
607 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
608 gfc_add_modify (block
, tmp
, tmp2
);
612 /* Takes a derived type expression and returns the address of a temporary
613 class object of the 'declared' type. If vptr is not NULL, this is
614 used for the temporary class object.
615 optional_alloc_ptr is false when the dummy is neither allocatable
616 nor a pointer; that's only relevant for the optional handling. */
618 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
619 gfc_typespec class_ts
, tree vptr
, bool optional
,
620 bool optional_alloc_ptr
)
623 tree cond_optional
= NULL_TREE
;
630 /* The derived type needs to be converted to a temporary
632 tmp
= gfc_typenode_for_spec (&class_ts
);
633 var
= gfc_create_var (tmp
, "class");
636 ctree
= gfc_class_vptr_get (var
);
638 if (vptr
!= NULL_TREE
)
640 /* Use the dynamic vptr. */
645 /* In this case the vtab corresponds to the derived type and the
646 vptr must point to it. */
647 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
649 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
651 gfc_add_modify (&parmse
->pre
, ctree
,
652 fold_convert (TREE_TYPE (ctree
), tmp
));
654 /* Now set the data field. */
655 ctree
= gfc_class_data_get (var
);
658 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
660 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
662 /* If there is a ready made pointer to a derived type, use it
663 rather than evaluating the expression again. */
664 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
665 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
667 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
669 /* For an array reference in an elemental procedure call we need
670 to retain the ss to provide the scalarized array reference. */
671 gfc_conv_expr_reference (parmse
, e
);
672 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
674 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
676 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
677 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
681 ss
= gfc_walk_expr (e
);
682 if (ss
== gfc_ss_terminator
)
685 gfc_conv_expr_reference (parmse
, e
);
687 /* Scalar to an assumed-rank array. */
688 if (class_ts
.u
.derived
->components
->as
)
691 type
= get_scalar_to_descriptor_type (parmse
->expr
,
693 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
694 gfc_get_dtype (type
));
696 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
697 TREE_TYPE (parmse
->expr
),
698 cond_optional
, parmse
->expr
,
699 fold_convert (TREE_TYPE (parmse
->expr
),
701 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
705 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
707 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
709 fold_convert (TREE_TYPE (tmp
),
711 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
717 gfc_init_block (&block
);
721 parmse
->use_offset
= 1;
722 gfc_conv_expr_descriptor (parmse
, e
);
724 /* Detect any array references with vector subscripts. */
725 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
726 if (ref
->type
== REF_ARRAY
727 && ref
->u
.ar
.type
!= AR_ELEMENT
728 && ref
->u
.ar
.type
!= AR_FULL
)
730 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
731 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
733 if (dim
< ref
->u
.ar
.dimen
)
737 /* Array references with vector subscripts and non-variable expressions
738 need be converted to a one-based descriptor. */
739 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
741 for (dim
= 0; dim
< e
->rank
; ++dim
)
742 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
746 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
748 gcc_assert (class_ts
.u
.derived
->components
->as
->type
750 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
754 if (gfc_expr_attr (e
).codimension
)
755 parmse
->expr
= fold_build1_loc (input_location
,
759 gfc_add_modify (&block
, ctree
, parmse
->expr
);
764 tmp
= gfc_finish_block (&block
);
766 gfc_init_block (&block
);
767 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
769 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
770 gfc_finish_block (&block
));
771 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
774 gfc_add_block_to_block (&parmse
->pre
, &block
);
778 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
779 && class_ts
.u
.derived
->components
->ts
.u
.derived
780 ->attr
.unlimited_polymorphic
)
782 /* Take care about initializing the _len component correctly. */
783 ctree
= gfc_class_len_get (var
);
784 if (UNLIMITED_POLY (e
))
789 len
= gfc_find_and_cut_at_last_class_ref (e
);
790 gfc_add_len_component (len
);
791 gfc_init_se (&se
, NULL
);
792 gfc_conv_expr (&se
, len
);
794 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
795 cond_optional
, se
.expr
,
796 fold_convert (TREE_TYPE (se
.expr
),
803 tmp
= integer_zero_node
;
804 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
807 /* Pass the address of the class object. */
808 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
810 if (optional
&& optional_alloc_ptr
)
811 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
812 TREE_TYPE (parmse
->expr
),
813 cond_optional
, parmse
->expr
,
814 fold_convert (TREE_TYPE (parmse
->expr
),
819 /* Create a new class container, which is required as scalar coarrays
820 have an array descriptor while normal scalars haven't. Optionally,
821 NULL pointer checks are added if the argument is OPTIONAL. */
824 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
825 gfc_typespec class_ts
, bool optional
)
827 tree var
, ctree
, tmp
;
832 gfc_init_block (&block
);
835 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
837 if (ref
->type
== REF_COMPONENT
838 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
842 if (class_ref
== NULL
843 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
844 tmp
= e
->symtree
->n
.sym
->backend_decl
;
847 /* Remove everything after the last class reference, convert the
848 expression and then recover its tailend once more. */
850 ref
= class_ref
->next
;
851 class_ref
->next
= NULL
;
852 gfc_init_se (&tmpse
, NULL
);
853 gfc_conv_expr (&tmpse
, e
);
854 class_ref
->next
= ref
;
858 var
= gfc_typenode_for_spec (&class_ts
);
859 var
= gfc_create_var (var
, "class");
861 ctree
= gfc_class_vptr_get (var
);
862 gfc_add_modify (&block
, ctree
,
863 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
865 ctree
= gfc_class_data_get (var
);
866 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
867 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
869 /* Pass the address of the class object. */
870 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
874 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
877 tmp
= gfc_finish_block (&block
);
879 gfc_init_block (&block
);
880 tmp2
= gfc_class_data_get (var
);
881 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
883 tmp2
= gfc_finish_block (&block
);
885 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
887 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
890 gfc_add_block_to_block (&parmse
->pre
, &block
);
894 /* Takes an intrinsic type expression and returns the address of a temporary
895 class object of the 'declared' type. */
897 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
898 gfc_typespec class_ts
)
907 /* The intrinsic type needs to be converted to a temporary
909 tmp
= gfc_typenode_for_spec (&class_ts
);
910 var
= gfc_create_var (tmp
, "class");
913 ctree
= gfc_class_vptr_get (var
);
915 vtab
= gfc_find_vtab (&e
->ts
);
917 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
918 gfc_add_modify (&parmse
->pre
, ctree
,
919 fold_convert (TREE_TYPE (ctree
), tmp
));
921 /* Now set the data field. */
922 ctree
= gfc_class_data_get (var
);
923 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
925 /* For an array reference in an elemental procedure call we need
926 to retain the ss to provide the scalarized array reference. */
927 gfc_conv_expr_reference (parmse
, e
);
928 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
929 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
933 ss
= gfc_walk_expr (e
);
934 if (ss
== gfc_ss_terminator
)
937 gfc_conv_expr_reference (parmse
, e
);
938 if (class_ts
.u
.derived
->components
->as
939 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
941 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
943 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
944 TREE_TYPE (ctree
), tmp
);
947 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
948 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
953 parmse
->use_offset
= 1;
954 gfc_conv_expr_descriptor (parmse
, e
);
956 /* Array references with vector subscripts and non-variable expressions
957 need be converted to a one-based descriptor. */
958 if (e
->expr_type
!= EXPR_VARIABLE
)
960 for (dim
= 0; dim
< e
->rank
; ++dim
)
961 gfc_conv_shift_descriptor_lbound (&parmse
->pre
, parmse
->expr
,
962 dim
, gfc_index_one_node
);
965 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
967 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
968 TREE_TYPE (ctree
), parmse
->expr
);
969 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
972 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
976 gcc_assert (class_ts
.type
== BT_CLASS
);
977 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
978 && class_ts
.u
.derived
->components
->ts
.u
.derived
979 ->attr
.unlimited_polymorphic
)
981 ctree
= gfc_class_len_get (var
);
982 /* When the actual arg is a char array, then set the _len component of the
983 unlimited polymorphic entity to the length of the string. */
984 if (e
->ts
.type
== BT_CHARACTER
)
986 /* Start with parmse->string_length because this seems to be set to a
987 correct value more often. */
988 if (parmse
->string_length
)
989 tmp
= parmse
->string_length
;
990 /* When the string_length is not yet set, then try the backend_decl of
992 else if (e
->ts
.u
.cl
->backend_decl
)
993 tmp
= e
->ts
.u
.cl
->backend_decl
;
994 /* If both of the above approaches fail, then try to generate an
995 expression from the input, which is only feasible currently, when the
996 expression can be evaluated to a constant one. */
999 /* Try to simplify the expression. */
1000 gfc_simplify_expr (e
, 0);
1001 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
1003 /* Amazingly all data is present to compute the length of a
1004 constant string, but the expression is not yet there. */
1005 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
1006 gfc_charlen_int_kind
,
1008 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
1009 e
->value
.character
.length
);
1010 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1011 e
->ts
.u
.cl
->resolved
= 1;
1012 tmp
= e
->ts
.u
.cl
->backend_decl
;
1016 gfc_error ("Cannot compute the length of the char array "
1017 "at %L.", &e
->where
);
1022 tmp
= integer_zero_node
;
1024 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
1026 else if (class_ts
.type
== BT_CLASS
1027 && class_ts
.u
.derived
->components
1028 && class_ts
.u
.derived
->components
->ts
.u
1029 .derived
->attr
.unlimited_polymorphic
)
1031 ctree
= gfc_class_len_get (var
);
1032 gfc_add_modify (&parmse
->pre
, ctree
,
1033 fold_convert (TREE_TYPE (ctree
),
1034 integer_zero_node
));
1036 /* Pass the address of the class object. */
1037 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1041 /* Takes a scalarized class array expression and returns the
1042 address of a temporary scalar class object of the 'declared'
1044 OOP-TODO: This could be improved by adding code that branched on
1045 the dynamic type being the same as the declared type. In this case
1046 the original class expression can be passed directly.
1047 optional_alloc_ptr is false when the dummy is neither allocatable
1048 nor a pointer; that's relevant for the optional handling.
1049 Set copyback to true if class container's _data and _vtab pointers
1050 might get modified. */
1053 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
1054 bool elemental
, bool copyback
, bool optional
,
1055 bool optional_alloc_ptr
)
1061 tree cond
= NULL_TREE
;
1062 tree slen
= NULL_TREE
;
1066 bool full_array
= false;
1068 gfc_init_block (&block
);
1071 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1073 if (ref
->type
== REF_COMPONENT
1074 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1077 if (ref
->next
== NULL
)
1081 if ((ref
== NULL
|| class_ref
== ref
)
1082 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1083 && (!class_ts
.u
.derived
->components
->as
1084 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1087 /* Test for FULL_ARRAY. */
1088 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1089 && gfc_expr_attr (e
).dimension
)
1092 gfc_is_class_array_ref (e
, &full_array
);
1094 /* The derived type needs to be converted to a temporary
1096 tmp
= gfc_typenode_for_spec (&class_ts
);
1097 var
= gfc_create_var (tmp
, "class");
1100 ctree
= gfc_class_data_get (var
);
1101 if (class_ts
.u
.derived
->components
->as
1102 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1106 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1108 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1109 gfc_get_dtype (type
));
1111 tmp
= gfc_class_data_get (parmse
->expr
);
1112 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1113 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1115 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1118 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1122 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1123 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1124 TREE_TYPE (ctree
), parmse
->expr
);
1125 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1128 /* Return the data component, except in the case of scalarized array
1129 references, where nullification of the cannot occur and so there
1131 if (!elemental
&& full_array
&& copyback
)
1133 if (class_ts
.u
.derived
->components
->as
1134 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1137 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1138 gfc_conv_descriptor_data_get (ctree
));
1140 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1143 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1147 ctree
= gfc_class_vptr_get (var
);
1149 /* The vptr is the second field of the actual argument.
1150 First we have to find the corresponding class reference. */
1153 if (gfc_is_class_array_function (e
)
1154 && parmse
->class_vptr
!= NULL_TREE
)
1155 tmp
= parmse
->class_vptr
;
1156 else if (class_ref
== NULL
1157 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1159 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1161 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1162 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1164 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1165 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1167 slen
= build_zero_cst (size_type_node
);
1171 /* Remove everything after the last class reference, convert the
1172 expression and then recover its tailend once more. */
1174 ref
= class_ref
->next
;
1175 class_ref
->next
= NULL
;
1176 gfc_init_se (&tmpse
, NULL
);
1177 gfc_conv_expr (&tmpse
, e
);
1178 class_ref
->next
= ref
;
1180 slen
= tmpse
.string_length
;
1183 gcc_assert (tmp
!= NULL_TREE
);
1185 /* Dereference if needs be. */
1186 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1187 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1189 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1190 vptr
= gfc_class_vptr_get (tmp
);
1194 gfc_add_modify (&block
, ctree
,
1195 fold_convert (TREE_TYPE (ctree
), vptr
));
1197 /* Return the vptr component, except in the case of scalarized array
1198 references, where the dynamic type cannot change. */
1199 if (!elemental
&& full_array
&& copyback
)
1200 gfc_add_modify (&parmse
->post
, vptr
,
1201 fold_convert (TREE_TYPE (vptr
), ctree
));
1203 /* For unlimited polymorphic objects also set the _len component. */
1204 if (class_ts
.type
== BT_CLASS
1205 && class_ts
.u
.derived
->components
1206 && class_ts
.u
.derived
->components
->ts
.u
1207 .derived
->attr
.unlimited_polymorphic
)
1209 ctree
= gfc_class_len_get (var
);
1210 if (UNLIMITED_POLY (e
))
1211 tmp
= gfc_class_len_get (tmp
);
1212 else if (e
->ts
.type
== BT_CHARACTER
)
1214 gcc_assert (slen
!= NULL_TREE
);
1218 tmp
= build_zero_cst (size_type_node
);
1219 gfc_add_modify (&parmse
->pre
, ctree
,
1220 fold_convert (TREE_TYPE (ctree
), tmp
));
1222 /* Return the len component, except in the case of scalarized array
1223 references, where the dynamic type cannot change. */
1224 if (!elemental
&& full_array
&& copyback
1225 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1226 gfc_add_modify (&parmse
->post
, tmp
,
1227 fold_convert (TREE_TYPE (tmp
), ctree
));
1234 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1235 /* parmse->pre may contain some preparatory instructions for the
1236 temporary array descriptor. Those may only be executed when the
1237 optional argument is set, therefore add parmse->pre's instructions
1238 to block, which is later guarded by an if (optional_arg_given). */
1239 gfc_add_block_to_block (&parmse
->pre
, &block
);
1240 block
.head
= parmse
->pre
.head
;
1241 parmse
->pre
.head
= NULL_TREE
;
1242 tmp
= gfc_finish_block (&block
);
1244 if (optional_alloc_ptr
)
1245 tmp2
= build_empty_stmt (input_location
);
1248 gfc_init_block (&block
);
1250 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1251 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1252 null_pointer_node
));
1253 tmp2
= gfc_finish_block (&block
);
1256 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1258 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1261 gfc_add_block_to_block (&parmse
->pre
, &block
);
1263 /* Pass the address of the class object. */
1264 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1266 if (optional
&& optional_alloc_ptr
)
1267 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1268 TREE_TYPE (parmse
->expr
),
1270 fold_convert (TREE_TYPE (parmse
->expr
),
1271 null_pointer_node
));
1275 /* Given a class array declaration and an index, returns the address
1276 of the referenced element. */
1279 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1282 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1284 data
= data_comp
!= NULL_TREE
? data_comp
:
1285 gfc_class_data_get (class_decl
);
1286 size
= gfc_class_vtab_size_get (class_decl
);
1290 tmp
= fold_convert (gfc_array_index_type
,
1291 gfc_class_len_get (class_decl
));
1292 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1293 gfc_array_index_type
, size
, tmp
);
1294 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1295 logical_type_node
, tmp
,
1296 build_zero_cst (TREE_TYPE (tmp
)));
1297 size
= fold_build3_loc (input_location
, COND_EXPR
,
1298 gfc_array_index_type
, tmp
, ctmp
, size
);
1301 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1302 gfc_array_index_type
,
1305 data
= gfc_conv_descriptor_data_get (data
);
1306 ptr
= fold_convert (pvoid_type_node
, data
);
1307 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1308 return fold_convert (TREE_TYPE (data
), ptr
);
1312 /* Copies one class expression to another, assuming that if either
1313 'to' or 'from' are arrays they are packed. Should 'from' be
1314 NULL_TREE, the initialization expression for 'to' is used, assuming
1315 that the _vptr is set. */
1318 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1328 vec
<tree
, va_gc
> *args
;
1333 bool is_from_desc
= false, is_to_class
= false;
1336 /* To prevent warnings on uninitialized variables. */
1337 from_len
= to_len
= NULL_TREE
;
1339 if (from
!= NULL_TREE
)
1340 fcn
= gfc_class_vtab_copy_get (from
);
1342 fcn
= gfc_class_vtab_copy_get (to
);
1344 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1346 if (from
!= NULL_TREE
)
1348 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1352 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1356 /* Check that from is a class. When the class is part of a coarray,
1357 then from is a common pointer and is to be used as is. */
1358 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1359 ? build_fold_indirect_ref (from
) : from
;
1361 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1362 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1363 ? gfc_class_data_get (from
) : from
;
1364 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1368 from_data
= gfc_class_vtab_def_init_get (to
);
1372 if (from
!= NULL_TREE
&& unlimited
)
1373 from_len
= gfc_class_len_or_zero_get (from
);
1375 from_len
= build_zero_cst (size_type_node
);
1378 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1381 to_data
= gfc_class_data_get (to
);
1383 to_len
= gfc_class_len_get (to
);
1386 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1389 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1391 stmtblock_t loopbody
;
1395 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1397 gfc_init_block (&body
);
1398 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1399 gfc_array_index_type
, nelems
,
1400 gfc_index_one_node
);
1401 nelems
= gfc_evaluate_now (tmp
, &body
);
1402 index
= gfc_create_var (gfc_array_index_type
, "S");
1406 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1408 vec_safe_push (args
, from_ref
);
1411 vec_safe_push (args
, from_data
);
1414 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1417 tmp
= gfc_conv_array_data (to
);
1418 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1419 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1420 gfc_build_array_ref (tmp
, index
, to
));
1422 vec_safe_push (args
, to_ref
);
1424 /* Add bounds check. */
1425 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1428 const char *name
= "<<unknown>>";
1432 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1434 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1435 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1436 logical_type_node
, from_len
, orig_nelems
);
1437 msg
= xasprintf ("Array bound mismatch for dimension %d "
1438 "of array '%s' (%%ld/%%ld)",
1441 gfc_trans_runtime_check (true, false, tmp
, &body
,
1442 &gfc_current_locus
, msg
,
1443 fold_convert (long_integer_type_node
, orig_nelems
),
1444 fold_convert (long_integer_type_node
, from_len
));
1449 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1451 /* Build the body of the loop. */
1452 gfc_init_block (&loopbody
);
1453 gfc_add_expr_to_block (&loopbody
, tmp
);
1455 /* Build the loop and return. */
1456 gfc_init_loopinfo (&loop
);
1458 loop
.from
[0] = gfc_index_zero_node
;
1459 loop
.loopvar
[0] = index
;
1460 loop
.to
[0] = nelems
;
1461 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1462 gfc_init_block (&ifbody
);
1463 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1464 stdcopy
= gfc_finish_block (&ifbody
);
1465 /* In initialization mode from_len is a constant zero. */
1466 if (unlimited
&& !integer_zerop (from_len
))
1468 vec_safe_push (args
, from_len
);
1469 vec_safe_push (args
, to_len
);
1470 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1471 /* Build the body of the loop. */
1472 gfc_init_block (&loopbody
);
1473 gfc_add_expr_to_block (&loopbody
, tmp
);
1475 /* Build the loop and return. */
1476 gfc_init_loopinfo (&loop
);
1478 loop
.from
[0] = gfc_index_zero_node
;
1479 loop
.loopvar
[0] = index
;
1480 loop
.to
[0] = nelems
;
1481 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1482 gfc_init_block (&ifbody
);
1483 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1484 extcopy
= gfc_finish_block (&ifbody
);
1486 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1487 logical_type_node
, from_len
,
1488 build_zero_cst (TREE_TYPE (from_len
)));
1489 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1490 void_type_node
, tmp
, extcopy
, stdcopy
);
1491 gfc_add_expr_to_block (&body
, tmp
);
1492 tmp
= gfc_finish_block (&body
);
1496 gfc_add_expr_to_block (&body
, stdcopy
);
1497 tmp
= gfc_finish_block (&body
);
1499 gfc_cleanup_loop (&loop
);
1503 gcc_assert (!is_from_desc
);
1504 vec_safe_push (args
, from_data
);
1505 vec_safe_push (args
, to_data
);
1506 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1508 /* In initialization mode from_len is a constant zero. */
1509 if (unlimited
&& !integer_zerop (from_len
))
1511 vec_safe_push (args
, from_len
);
1512 vec_safe_push (args
, to_len
);
1513 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1514 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1515 logical_type_node
, from_len
,
1516 build_zero_cst (TREE_TYPE (from_len
)));
1517 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1518 void_type_node
, tmp
, extcopy
, stdcopy
);
1524 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1525 if (from
== NULL_TREE
)
1528 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1530 from_data
, null_pointer_node
);
1531 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1532 void_type_node
, cond
,
1533 tmp
, build_empty_stmt (input_location
));
1541 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1543 gfc_actual_arglist
*actual
;
1548 actual
= gfc_get_actual_arglist ();
1549 actual
->expr
= gfc_copy_expr (rhs
);
1550 actual
->next
= gfc_get_actual_arglist ();
1551 actual
->next
->expr
= gfc_copy_expr (lhs
);
1552 ppc
= gfc_copy_expr (obj
);
1553 gfc_add_vptr_component (ppc
);
1554 gfc_add_component_ref (ppc
, "_copy");
1555 ppc_code
= gfc_get_code (EXEC_CALL
);
1556 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1557 /* Although '_copy' is set to be elemental in class.c, it is
1558 not staying that way. Find out why, sometime.... */
1559 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1560 ppc_code
->ext
.actual
= actual
;
1561 ppc_code
->expr1
= ppc
;
1562 /* Since '_copy' is elemental, the scalarizer will take care
1563 of arrays in gfc_trans_call. */
1564 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1565 gfc_free_statements (ppc_code
);
1567 if (UNLIMITED_POLY(obj
))
1569 /* Check if rhs is non-NULL. */
1571 gfc_init_se (&src
, NULL
);
1572 gfc_conv_expr (&src
, rhs
);
1573 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1574 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1575 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1576 null_pointer_node
));
1577 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1578 build_empty_stmt (input_location
));
1584 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1585 A MEMCPY is needed to copy the full data from the default initializer
1586 of the dynamic type. */
1589 gfc_trans_class_init_assign (gfc_code
*code
)
1593 gfc_se dst
,src
,memsz
;
1594 gfc_expr
*lhs
, *rhs
, *sz
;
1596 gfc_start_block (&block
);
1598 lhs
= gfc_copy_expr (code
->expr1
);
1600 rhs
= gfc_copy_expr (code
->expr1
);
1601 gfc_add_vptr_component (rhs
);
1603 /* Make sure that the component backend_decls have been built, which
1604 will not have happened if the derived types concerned have not
1606 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1607 gfc_add_def_init_component (rhs
);
1608 /* The _def_init is always scalar. */
1611 if (code
->expr1
->ts
.type
== BT_CLASS
1612 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1614 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1615 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1616 /* Adding the array ref to the class expression results in correct
1617 indexing to the dynamic type. */
1618 gfc_add_full_array_ref (lhs
, tmparr
);
1619 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1623 /* Scalar initialization needs the _data component. */
1624 gfc_add_data_component (lhs
);
1625 sz
= gfc_copy_expr (code
->expr1
);
1626 gfc_add_vptr_component (sz
);
1627 gfc_add_size_component (sz
);
1629 gfc_init_se (&dst
, NULL
);
1630 gfc_init_se (&src
, NULL
);
1631 gfc_init_se (&memsz
, NULL
);
1632 gfc_conv_expr (&dst
, lhs
);
1633 gfc_conv_expr (&src
, rhs
);
1634 gfc_conv_expr (&memsz
, sz
);
1635 gfc_add_block_to_block (&block
, &src
.pre
);
1636 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1638 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1640 if (UNLIMITED_POLY(code
->expr1
))
1642 /* Check if _def_init is non-NULL. */
1643 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1644 logical_type_node
, src
.expr
,
1645 fold_convert (TREE_TYPE (src
.expr
),
1646 null_pointer_node
));
1647 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1648 tmp
, build_empty_stmt (input_location
));
1652 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1653 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1655 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1656 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1658 build_empty_stmt (input_location
));
1661 gfc_add_expr_to_block (&block
, tmp
);
1663 return gfc_finish_block (&block
);
1667 /* Class valued elemental function calls or class array elements arriving
1668 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1669 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1672 trans_scalar_class_assign (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
)
1681 stmtblock_t inner_block
;
1683 bool not_call_expr
= TREE_CODE (rse
->expr
) != CALL_EXPR
;
1684 bool not_lhs_array_type
;
1686 /* Temporaries arising from depencies in assignment get cast as a
1687 character type of the dynamic size of the rhs. Use the vptr copy
1689 tmp
= TREE_TYPE (lse
->expr
);
1690 not_lhs_array_type
= !(tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
1691 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) != NULL_TREE
);
1693 /* Use ordinary assignment if the rhs is not a call expression or
1694 the lhs is not a class entity or an array(ie. character) type. */
1695 if ((not_call_expr
&& gfc_get_class_from_expr (lse
->expr
) == NULL_TREE
)
1696 && not_lhs_array_type
)
1699 /* Ordinary assignment can be used if both sides are class expressions
1700 since the dynamic type is preserved by copying the vptr. This
1701 should only occur, where temporaries are involved. */
1702 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
1703 && GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
1706 /* Fix the class expression and the class data of the rhs. */
1707 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
1710 tmp
= gfc_get_class_from_expr (rse
->expr
);
1711 if (tmp
== NULL_TREE
)
1713 rse_expr
= gfc_evaluate_now (tmp
, block
);
1716 rse_expr
= gfc_evaluate_now (rse
->expr
, block
);
1718 class_data
= gfc_class_data_get (rse_expr
);
1720 /* Check that the rhs data is not null. */
1721 is_descriptor
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data
));
1723 class_data
= gfc_conv_descriptor_data_get (class_data
);
1724 class_data
= gfc_evaluate_now (class_data
, block
);
1726 zero
= build_int_cst (TREE_TYPE (class_data
), 0);
1727 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1731 /* Copy the rhs to the lhs. */
1732 fcn
= gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr
));
1733 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1734 tmp
= gfc_evaluate_now (gfc_build_addr_expr (NULL
, rse
->expr
), block
);
1735 tmp
= is_descriptor
? tmp
: class_data
;
1736 tmp
= build_call_expr_loc (input_location
, fcn
, 2, tmp
,
1737 gfc_build_addr_expr (NULL
, lse
->expr
));
1738 gfc_add_expr_to_block (block
, tmp
);
1740 /* Only elemental function results need to be finalised and freed. */
1744 /* Finalize the class data if needed. */
1745 gfc_init_block (&inner_block
);
1746 fcn
= gfc_vptr_final_get (gfc_class_vptr_get (rse_expr
));
1747 zero
= build_int_cst (TREE_TYPE (fcn
), 0);
1748 final_cond
= fold_build2_loc (input_location
, NE_EXPR
,
1749 logical_type_node
, fcn
, zero
);
1750 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1751 tmp
= build_call_expr_loc (input_location
, fcn
, 1, class_data
);
1752 tmp
= build3_v (COND_EXPR
, final_cond
,
1753 tmp
, build_empty_stmt (input_location
));
1754 gfc_add_expr_to_block (&inner_block
, tmp
);
1756 /* Free the class data. */
1757 tmp
= gfc_call_free (class_data
);
1758 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1759 build_empty_stmt (input_location
));
1760 gfc_add_expr_to_block (&inner_block
, tmp
);
1762 /* Finish the inner block and subject it to the condition on the
1763 class data being non-zero. */
1764 tmp
= gfc_finish_block (&inner_block
);
1765 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1766 build_empty_stmt (input_location
));
1767 gfc_add_expr_to_block (block
, tmp
);
1772 /* End of prototype trans-class.c */
1776 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1778 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1779 gfc_warning (OPT_Wrealloc_lhs
,
1780 "Code for reallocating the allocatable array at %L will "
1782 else if (warn_realloc_lhs_all
)
1783 gfc_warning (OPT_Wrealloc_lhs_all
,
1784 "Code for reallocating the allocatable variable at %L "
1785 "will be added", where
);
1789 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1792 /* Copy the scalarization loop variables. */
1795 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1798 dest
->loop
= src
->loop
;
1802 /* Initialize a simple expression holder.
1804 Care must be taken when multiple se are created with the same parent.
1805 The child se must be kept in sync. The easiest way is to delay creation
1806 of a child se until after the previous se has been translated. */
1809 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1811 memset (se
, 0, sizeof (gfc_se
));
1812 gfc_init_block (&se
->pre
);
1813 gfc_init_block (&se
->post
);
1815 se
->parent
= parent
;
1818 gfc_copy_se_loopvars (se
, parent
);
1822 /* Advances to the next SS in the chain. Use this rather than setting
1823 se->ss = se->ss->next because all the parents needs to be kept in sync.
1827 gfc_advance_se_ss_chain (gfc_se
* se
)
1832 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1835 /* Walk down the parent chain. */
1838 /* Simple consistency check. */
1839 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1840 || p
->parent
->ss
->nested_ss
== p
->ss
);
1842 /* If we were in a nested loop, the next scalarized expression can be
1843 on the parent ss' next pointer. Thus we should not take the next
1844 pointer blindly, but rather go up one nest level as long as next
1845 is the end of chain. */
1847 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1857 /* Ensures the result of the expression as either a temporary variable
1858 or a constant so that it can be used repeatedly. */
1861 gfc_make_safe_expr (gfc_se
* se
)
1865 if (CONSTANT_CLASS_P (se
->expr
))
1868 /* We need a temporary for this result. */
1869 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1870 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1875 /* Return an expression which determines if a dummy parameter is present.
1876 Also used for arguments to procedures with multiple entry points. */
1879 gfc_conv_expr_present (gfc_symbol
* sym
, bool use_saved_desc
)
1881 tree decl
, orig_decl
, cond
;
1883 gcc_assert (sym
->attr
.dummy
);
1884 orig_decl
= decl
= gfc_get_symbol_decl (sym
);
1886 /* Intrinsic scalars with VALUE attribute which are passed by value
1887 use a hidden argument to denote the present status. */
1888 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1889 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1890 && !sym
->attr
.dimension
)
1892 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1895 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1897 strcpy (&name
[1], sym
->name
);
1898 tree_name
= get_identifier (name
);
1900 /* Walk function argument list to find hidden arg. */
1901 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1902 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1903 if (DECL_NAME (cond
) == tree_name
1904 && DECL_ARTIFICIAL (cond
))
1911 /* Assumed-shape arrays use a local variable for the array data;
1912 the actual PARAM_DECL is in a saved decl. As the local variable
1913 is NULL, it can be checked instead, unless use_saved_desc is
1916 if (use_saved_desc
&& TREE_CODE (decl
) != PARM_DECL
)
1918 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1919 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1920 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1923 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1924 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1926 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1927 as actual argument to denote absent dummies. For array descriptors,
1928 we thus also need to check the array descriptor. For BT_CLASS, it
1929 can also occur for scalars and F2003 due to type->class wrapping and
1930 class->class wrapping. Note further that BT_CLASS always uses an
1931 array descriptor for arrays, also for explicit-shape/assumed-size.
1932 For assumed-rank arrays, no local variable is generated, hence,
1933 the following also applies with !use_saved_desc. */
1935 if ((use_saved_desc
|| TREE_CODE (orig_decl
) == PARM_DECL
)
1936 && !sym
->attr
.allocatable
1937 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1938 || (sym
->ts
.type
== BT_CLASS
1939 && !CLASS_DATA (sym
)->attr
.allocatable
1940 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1941 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1942 || sym
->ts
.type
== BT_CLASS
))
1946 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1947 || sym
->as
->type
== AS_ASSUMED_RANK
1948 || sym
->attr
.codimension
))
1949 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1951 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1952 if (sym
->ts
.type
== BT_CLASS
)
1953 tmp
= gfc_class_data_get (tmp
);
1954 tmp
= gfc_conv_array_data (tmp
);
1956 else if (sym
->ts
.type
== BT_CLASS
)
1957 tmp
= gfc_class_data_get (decl
);
1961 if (tmp
!= NULL_TREE
)
1963 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1964 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1965 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1966 logical_type_node
, cond
, tmp
);
1974 /* Converts a missing, dummy argument into a null or zero. */
1977 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1982 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1986 /* Create a temporary and convert it to the correct type. */
1987 tmp
= gfc_get_int_type (kind
);
1988 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1991 /* Test for a NULL value. */
1992 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1993 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1994 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1995 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1999 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
2001 build_zero_cst (TREE_TYPE (se
->expr
)));
2002 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2006 if (ts
.type
== BT_CHARACTER
)
2008 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2009 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
2010 present
, se
->string_length
, tmp
);
2011 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2012 se
->string_length
= tmp
;
2018 /* Get the character length of an expression, looking through gfc_refs
2022 gfc_get_expr_charlen (gfc_expr
*e
)
2028 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2029 && e
->ts
.type
== BT_CHARACTER
);
2031 length
= NULL
; /* To silence compiler warning. */
2033 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
2036 gfc_init_se (&tmpse
, NULL
);
2037 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
2038 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
2042 /* First candidate: if the variable is of type CHARACTER, the
2043 expression's length could be the length of the character
2045 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2046 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2048 /* Look through the reference chain for component references. */
2049 for (r
= e
->ref
; r
; r
= r
->next
)
2054 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
2055 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
2063 gfc_init_se (&se
, NULL
);
2064 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
2066 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
2067 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
2068 gfc_charlen_type_node
,
2070 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
2071 gfc_charlen_type_node
, length
,
2072 gfc_index_one_node
);
2081 gcc_assert (length
!= NULL
);
2086 /* Return for an expression the backend decl of the coarray. */
2089 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
2095 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
2097 /* Not-implemented diagnostic. */
2098 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
2099 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
2100 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2101 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2102 "%L is not supported", &expr
->where
);
2104 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2105 if (ref
->type
== REF_COMPONENT
)
2107 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
2108 && UNLIMITED_POLY (ref
->u
.c
.component
)
2109 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
2110 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2111 "component at %L is not supported", &expr
->where
);
2114 /* Make sure the backend_decl is present before accessing it. */
2115 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
2116 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
2117 : expr
->symtree
->n
.sym
->backend_decl
;
2119 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2121 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
2123 caf_decl
= gfc_class_data_get (caf_decl
);
2124 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2127 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2129 if (ref
->type
== REF_COMPONENT
2130 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
2132 caf_decl
= gfc_class_data_get (caf_decl
);
2133 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2137 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
2141 if (expr
->symtree
->n
.sym
->attr
.codimension
)
2144 /* The following code assumes that the coarray is a component reachable via
2145 only scalar components/variables; the Fortran standard guarantees this. */
2147 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2148 if (ref
->type
== REF_COMPONENT
)
2150 gfc_component
*comp
= ref
->u
.c
.component
;
2152 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
2153 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2154 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2155 TREE_TYPE (comp
->backend_decl
), caf_decl
,
2156 comp
->backend_decl
, NULL_TREE
);
2157 if (comp
->ts
.type
== BT_CLASS
)
2159 caf_decl
= gfc_class_data_get (caf_decl
);
2160 if (CLASS_DATA (comp
)->attr
.codimension
)
2166 if (comp
->attr
.codimension
)
2172 gcc_assert (found
&& caf_decl
);
2177 /* Obtain the Coarray token - and optionally also the offset. */
2180 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2181 tree se_expr
, gfc_expr
*expr
)
2185 /* Coarray token. */
2186 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2188 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2189 == GFC_ARRAY_ALLOCATABLE
2190 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2191 *token
= gfc_conv_descriptor_token (caf_decl
);
2193 else if (DECL_LANG_SPECIFIC (caf_decl
)
2194 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2195 *token
= GFC_DECL_TOKEN (caf_decl
);
2198 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2199 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2200 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2206 /* Offset between the coarray base address and the address wanted. */
2207 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2208 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2209 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2210 *offset
= build_int_cst (gfc_array_index_type
, 0);
2211 else if (DECL_LANG_SPECIFIC (caf_decl
)
2212 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2213 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2214 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2215 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2217 *offset
= build_int_cst (gfc_array_index_type
, 0);
2219 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2220 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2222 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2223 tmp
= gfc_conv_descriptor_data_get (tmp
);
2225 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2226 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2229 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2233 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2234 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2236 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2237 && expr
->symtree
->n
.sym
->attr
.codimension
2238 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2240 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2241 gfc_ref
*ref
= base_expr
->ref
;
2244 // Iterate through the refs until the last one.
2248 if (ref
->type
== REF_ARRAY
2249 && ref
->u
.ar
.type
!= AR_FULL
)
2251 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2253 for (i
= 0; i
< ranksum
; ++i
)
2255 ref
->u
.ar
.start
[i
] = NULL
;
2256 ref
->u
.ar
.end
[i
] = NULL
;
2258 ref
->u
.ar
.type
= AR_FULL
;
2260 gfc_init_se (&base_se
, NULL
);
2261 if (gfc_caf_attr (base_expr
).dimension
)
2263 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2264 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2268 gfc_conv_expr (&base_se
, base_expr
);
2272 gfc_free_expr (base_expr
);
2273 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2274 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2276 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2277 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2280 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2284 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2285 fold_convert (gfc_array_index_type
, *offset
),
2286 fold_convert (gfc_array_index_type
, tmp
));
2290 /* Convert the coindex of a coarray into an image index; the result is
2291 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2292 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2295 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2298 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2302 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2303 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2305 gcc_assert (ref
!= NULL
);
2307 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2309 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2313 img_idx
= build_zero_cst (gfc_array_index_type
);
2314 extent
= build_one_cst (gfc_array_index_type
);
2315 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2316 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2318 gfc_init_se (&se
, NULL
);
2319 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2320 gfc_add_block_to_block (block
, &se
.pre
);
2321 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2322 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2323 TREE_TYPE (lbound
), se
.expr
, lbound
);
2324 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2326 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2327 TREE_TYPE (tmp
), img_idx
, tmp
);
2328 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2330 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2331 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2332 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2333 TREE_TYPE (tmp
), extent
, tmp
);
2337 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2339 gfc_init_se (&se
, NULL
);
2340 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2341 gfc_add_block_to_block (block
, &se
.pre
);
2342 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2343 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2344 TREE_TYPE (lbound
), se
.expr
, lbound
);
2345 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2347 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2349 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2351 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2352 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2353 TREE_TYPE (ubound
), ubound
, lbound
);
2354 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2355 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2356 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2357 TREE_TYPE (tmp
), extent
, tmp
);
2360 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2361 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2362 return fold_convert (integer_type_node
, img_idx
);
2366 /* For each character array constructor subexpression without a ts.u.cl->length,
2367 replace it by its first element (if there aren't any elements, the length
2368 should already be set to zero). */
2371 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2373 gfc_actual_arglist
* arg
;
2379 switch (e
->expr_type
)
2383 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2384 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2388 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2392 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2393 flatten_array_ctors_without_strlen (arg
->expr
);
2398 /* We've found what we're looking for. */
2399 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2404 gcc_assert (e
->value
.constructor
);
2406 c
= gfc_constructor_first (e
->value
.constructor
);
2410 flatten_array_ctors_without_strlen (new_expr
);
2411 gfc_replace_expr (e
, new_expr
);
2415 /* Otherwise, fall through to handle constructor elements. */
2417 case EXPR_STRUCTURE
:
2418 for (c
= gfc_constructor_first (e
->value
.constructor
);
2419 c
; c
= gfc_constructor_next (c
))
2420 flatten_array_ctors_without_strlen (c
->expr
);
2430 /* Generate code to initialize a string length variable. Returns the
2431 value. For array constructors, cl->length might be NULL and in this case,
2432 the first element of the constructor is needed. expr is the original
2433 expression so we can access it but can be NULL if this is not needed. */
2436 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2440 gfc_init_se (&se
, NULL
);
2442 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2445 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2446 "flatten" array constructors by taking their first element; all elements
2447 should be the same length or a cl->length should be present. */
2450 gfc_expr
* expr_flat
;
2453 expr_flat
= gfc_copy_expr (expr
);
2454 flatten_array_ctors_without_strlen (expr_flat
);
2455 gfc_resolve_expr (expr_flat
);
2457 gfc_conv_expr (&se
, expr_flat
);
2458 gfc_add_block_to_block (pblock
, &se
.pre
);
2459 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2461 gfc_free_expr (expr_flat
);
2465 /* Convert cl->length. */
2467 gcc_assert (cl
->length
);
2469 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2470 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2471 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2472 gfc_add_block_to_block (pblock
, &se
.pre
);
2474 if (cl
->backend_decl
)
2475 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2477 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2482 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2483 const char *name
, locus
*where
)
2493 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2494 type
= build_pointer_type (type
);
2496 gfc_init_se (&start
, se
);
2497 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2498 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2500 if (integer_onep (start
.expr
))
2501 gfc_conv_string_parameter (se
);
2506 /* Avoid multiple evaluation of substring start. */
2507 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2508 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2510 /* Change the start of the string. */
2511 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2512 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2513 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2516 tmp
= build_fold_indirect_ref_loc (input_location
,
2518 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2519 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
2521 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2522 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2526 /* Length = end + 1 - start. */
2527 gfc_init_se (&end
, se
);
2528 if (ref
->u
.ss
.end
== NULL
)
2529 end
.expr
= se
->string_length
;
2532 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2533 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2537 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2538 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2540 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2542 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2543 logical_type_node
, start
.expr
,
2546 /* Check lower bound. */
2547 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2549 build_one_cst (TREE_TYPE (start
.expr
)));
2550 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2551 logical_type_node
, nonempty
, fault
);
2553 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2554 "is less than one", name
);
2556 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2557 "is less than one");
2558 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2559 fold_convert (long_integer_type_node
,
2563 /* Check upper bound. */
2564 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2565 end
.expr
, se
->string_length
);
2566 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2567 logical_type_node
, nonempty
, fault
);
2569 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2570 "exceeds string length (%%ld)", name
);
2572 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2573 "exceeds string length (%%ld)");
2574 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2575 fold_convert (long_integer_type_node
, end
.expr
),
2576 fold_convert (long_integer_type_node
,
2577 se
->string_length
));
2581 /* Try to calculate the length from the start and end expressions. */
2583 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2585 HOST_WIDE_INT i_len
;
2587 i_len
= gfc_mpz_get_hwi (length
) + 1;
2591 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2592 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2596 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2597 fold_convert (gfc_charlen_type_node
, end
.expr
),
2598 fold_convert (gfc_charlen_type_node
, start
.expr
));
2599 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2600 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2601 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2602 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2605 se
->string_length
= tmp
;
2609 /* Convert a derived type component reference. */
2612 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2620 c
= ref
->u
.c
.component
;
2622 if (c
->backend_decl
== NULL_TREE
2623 && ref
->u
.c
.sym
!= NULL
)
2624 gfc_get_derived_type (ref
->u
.c
.sym
);
2626 field
= c
->backend_decl
;
2627 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2629 context
= DECL_FIELD_CONTEXT (field
);
2631 /* Components can correspond to fields of different containing
2632 types, as components are created without context, whereas
2633 a concrete use of a component has the type of decl as context.
2634 So, if the type doesn't match, we search the corresponding
2635 FIELD_DECL in the parent type. To not waste too much time
2636 we cache this result in norestrict_decl.
2637 On the other hand, if the context is a UNION or a MAP (a
2638 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2640 if (context
!= TREE_TYPE (decl
)
2641 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2642 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2644 tree f2
= c
->norestrict_decl
;
2645 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2646 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2647 if (TREE_CODE (f2
) == FIELD_DECL
2648 && DECL_NAME (f2
) == DECL_NAME (field
))
2651 c
->norestrict_decl
= f2
;
2655 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2656 && strcmp ("_data", c
->name
) == 0)
2658 /* Found a ref to the _data component. Store the associated ref to
2659 the vptr in se->class_vptr. */
2660 se
->class_vptr
= gfc_class_vptr_get (decl
);
2663 se
->class_vptr
= NULL_TREE
;
2665 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2666 decl
, field
, NULL_TREE
);
2670 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2671 strlen () conditional below. */
2672 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2673 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2674 && !c
->attr
.pdt_string
)
2676 tmp
= c
->ts
.u
.cl
->backend_decl
;
2677 /* Components must always be constant length. */
2678 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2679 se
->string_length
= tmp
;
2682 if (gfc_deferred_strlen (c
, &field
))
2684 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2686 decl
, field
, NULL_TREE
);
2687 se
->string_length
= tmp
;
2690 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2691 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2692 && c
->ts
.type
!= BT_CHARACTER
)
2693 || c
->attr
.proc_pointer
)
2694 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2699 /* This function deals with component references to components of the
2700 parent type for derived type extensions. */
2702 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2710 c
= ref
->u
.c
.component
;
2712 /* Return if the component is in the parent type. */
2713 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2714 if (strcmp (c
->name
, cmp
->name
) == 0)
2717 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2718 parent
.type
= REF_COMPONENT
;
2720 parent
.u
.c
.sym
= dt
;
2721 parent
.u
.c
.component
= dt
->components
;
2723 if (dt
->backend_decl
== NULL
)
2724 gfc_get_derived_type (dt
);
2726 /* Build the reference and call self. */
2727 gfc_conv_component_ref (se
, &parent
);
2728 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2729 parent
.u
.c
.component
= c
;
2730 conv_parent_component_references (se
, &parent
);
2735 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2737 tree res
= se
->expr
;
2742 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2743 TREE_TYPE (TREE_TYPE (res
)), res
);
2747 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2748 TREE_TYPE (TREE_TYPE (res
)), res
);
2752 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2757 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2767 /* Dereference VAR where needed if it is a pointer, reference, etc.
2768 according to Fortran semantics. */
2771 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2774 /* Characters are entirely different from other types, they are treated
2776 if (sym
->ts
.type
== BT_CHARACTER
)
2778 /* Dereference character pointer dummy arguments
2780 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2781 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2783 || sym
->attr
.function
2784 || sym
->attr
.result
))
2785 var
= build_fold_indirect_ref_loc (input_location
, var
);
2787 else if (!sym
->attr
.value
)
2789 /* Dereference temporaries for class array dummy arguments. */
2790 if (sym
->attr
.dummy
&& is_classarray
2791 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2793 if (!descriptor_only_p
)
2794 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2796 var
= build_fold_indirect_ref_loc (input_location
, var
);
2799 /* Dereference non-character scalar dummy arguments. */
2800 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2801 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2802 && (sym
->ts
.type
!= BT_CLASS
2803 || (!CLASS_DATA (sym
)->attr
.dimension
2804 && !(CLASS_DATA (sym
)->attr
.codimension
2805 && CLASS_DATA (sym
)->attr
.allocatable
))))
2806 var
= build_fold_indirect_ref_loc (input_location
, var
);
2808 /* Dereference scalar hidden result. */
2809 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2810 && (sym
->attr
.function
|| sym
->attr
.result
)
2811 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2812 && !sym
->attr
.always_explicit
)
2813 var
= build_fold_indirect_ref_loc (input_location
, var
);
2815 /* Dereference non-character, non-class pointer variables.
2816 These must be dummies, results, or scalars. */
2818 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2819 || gfc_is_associate_pointer (sym
)
2820 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2822 || sym
->attr
.function
2824 || (!sym
->attr
.dimension
2825 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2826 var
= build_fold_indirect_ref_loc (input_location
, var
);
2827 /* Now treat the class array pointer variables accordingly. */
2828 else if (sym
->ts
.type
== BT_CLASS
2830 && (CLASS_DATA (sym
)->attr
.dimension
2831 || CLASS_DATA (sym
)->attr
.codimension
)
2832 && ((CLASS_DATA (sym
)->as
2833 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2834 || CLASS_DATA (sym
)->attr
.allocatable
2835 || CLASS_DATA (sym
)->attr
.class_pointer
))
2836 var
= build_fold_indirect_ref_loc (input_location
, var
);
2837 /* And the case where a non-dummy, non-result, non-function,
2838 non-allotable and non-pointer classarray is present. This case was
2839 previously covered by the first if, but with introducing the
2840 condition !is_classarray there, that case has to be covered
2842 else if (sym
->ts
.type
== BT_CLASS
2844 && !sym
->attr
.function
2845 && !sym
->attr
.result
2846 && (CLASS_DATA (sym
)->attr
.dimension
2847 || CLASS_DATA (sym
)->attr
.codimension
)
2849 || !CLASS_DATA (sym
)->attr
.allocatable
)
2850 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2851 var
= build_fold_indirect_ref_loc (input_location
, var
);
2857 /* Return the contents of a variable. Also handles reference/pointer
2858 variables (all Fortran pointer references are implicit). */
2861 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2866 tree parent_decl
= NULL_TREE
;
2869 bool alternate_entry
;
2872 bool first_time
= true;
2874 sym
= expr
->symtree
->n
.sym
;
2875 is_classarray
= IS_CLASS_ARRAY (sym
);
2879 gfc_ss_info
*ss_info
= ss
->info
;
2881 /* Check that something hasn't gone horribly wrong. */
2882 gcc_assert (ss
!= gfc_ss_terminator
);
2883 gcc_assert (ss_info
->expr
== expr
);
2885 /* A scalarized term. We already know the descriptor. */
2886 se
->expr
= ss_info
->data
.array
.descriptor
;
2887 se
->string_length
= ss_info
->string_length
;
2888 ref
= ss_info
->data
.array
.ref
;
2890 gcc_assert (ref
->type
== REF_ARRAY
2891 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2893 gfc_conv_tmp_array_ref (se
);
2897 tree se_expr
= NULL_TREE
;
2899 se
->expr
= gfc_get_symbol_decl (sym
);
2901 /* Deal with references to a parent results or entries by storing
2902 the current_function_decl and moving to the parent_decl. */
2903 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2904 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2905 && sym
->result
== sym
;
2906 entry_master
= sym
->attr
.result
2907 && sym
->ns
->proc_name
->attr
.entry_master
2908 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2909 if (current_function_decl
)
2910 parent_decl
= DECL_CONTEXT (current_function_decl
);
2912 if ((se
->expr
== parent_decl
&& return_value
)
2913 || (sym
->ns
&& sym
->ns
->proc_name
2915 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2916 && (alternate_entry
|| entry_master
)))
2921 /* Special case for assigning the return value of a function.
2922 Self recursive functions must have an explicit return value. */
2923 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2924 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2926 /* Similarly for alternate entry points. */
2927 else if (alternate_entry
2928 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2931 gfc_entry_list
*el
= NULL
;
2933 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2936 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2941 else if (entry_master
2942 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2944 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2949 /* Procedure actual arguments. Look out for temporary variables
2950 with the same attributes as function values. */
2951 else if (!sym
->attr
.temporary
2952 && sym
->attr
.flavor
== FL_PROCEDURE
2953 && se
->expr
!= current_function_decl
)
2955 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2957 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2958 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2963 /* Dereference the expression, where needed. */
2964 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
2970 /* For character variables, also get the length. */
2971 if (sym
->ts
.type
== BT_CHARACTER
)
2973 /* If the character length of an entry isn't set, get the length from
2974 the master function instead. */
2975 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2976 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2978 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2979 gcc_assert (se
->string_length
);
2982 gfc_typespec
*ts
= &sym
->ts
;
2988 /* Return the descriptor if that's what we want and this is an array
2989 section reference. */
2990 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2992 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2993 /* Return the descriptor for array pointers and allocations. */
2994 if (se
->want_pointer
2995 && ref
->next
== NULL
&& (se
->descriptor_only
))
2998 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2999 /* Return a pointer to an element. */
3003 ts
= &ref
->u
.c
.component
->ts
;
3004 if (first_time
&& is_classarray
&& sym
->attr
.dummy
3005 && se
->descriptor_only
3006 && !CLASS_DATA (sym
)->attr
.allocatable
3007 && !CLASS_DATA (sym
)->attr
.class_pointer
3008 && CLASS_DATA (sym
)->as
3009 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
3010 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
3011 /* Skip the first ref of a _data component, because for class
3012 arrays that one is already done by introducing a temporary
3013 array descriptor. */
3016 if (ref
->u
.c
.sym
->attr
.extension
)
3017 conv_parent_component_references (se
, ref
);
3019 gfc_conv_component_ref (se
, ref
);
3020 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
3021 && se
->want_pointer
&& se
->descriptor_only
)
3027 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
3028 expr
->symtree
->name
, &expr
->where
);
3032 conv_inquiry (se
, ref
, expr
, ts
);
3042 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3044 if (se
->want_pointer
)
3046 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
3047 gfc_conv_string_parameter (se
);
3049 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3054 /* Unary ops are easy... Or they would be if ! was a valid op. */
3057 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
3062 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3063 /* Initialize the operand. */
3064 gfc_init_se (&operand
, se
);
3065 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
3066 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
3068 type
= gfc_typenode_for_spec (&expr
->ts
);
3070 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3071 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3072 All other unary operators have an equivalent GIMPLE unary operator. */
3073 if (code
== TRUTH_NOT_EXPR
)
3074 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
3075 build_int_cst (type
, 0));
3077 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
3081 /* Expand power operator to optimal multiplications when a value is raised
3082 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3083 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3084 Programming", 3rd Edition, 1998. */
3086 /* This code is mostly duplicated from expand_powi in the backend.
3087 We establish the "optimal power tree" lookup table with the defined size.
3088 The items in the table are the exponents used to calculate the index
3089 exponents. Any integer n less than the value can get an "addition chain",
3090 with the first node being one. */
3091 #define POWI_TABLE_SIZE 256
3093 /* The table is from builtins.c. */
3094 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
3096 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3097 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3098 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3099 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3100 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3101 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3102 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3103 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3104 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3105 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3106 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3107 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3108 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3109 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3110 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3111 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3112 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3113 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3114 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3115 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3116 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3117 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3118 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3119 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3120 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3121 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3122 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3123 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3124 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3125 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3126 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3127 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3130 /* If n is larger than lookup table's max index, we use the "window
3132 #define POWI_WINDOW_SIZE 3
3134 /* Recursive function to expand the power operator. The temporary
3135 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3137 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
3144 if (n
< POWI_TABLE_SIZE
)
3149 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
3150 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
3154 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
3155 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
3156 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
3160 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
3164 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
3165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3167 if (n
< POWI_TABLE_SIZE
)
3174 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3175 return 1. Else return 0 and a call to runtime library functions
3176 will have to be built. */
3178 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3183 tree vartmp
[POWI_TABLE_SIZE
];
3185 unsigned HOST_WIDE_INT n
;
3187 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3189 /* If exponent is too large, we won't expand it anyway, so don't bother
3190 with large integer values. */
3191 if (!wi::fits_shwi_p (wrhs
))
3194 m
= wrhs
.to_shwi ();
3195 /* Use the wide_int's routine to reliably get the absolute value on all
3196 platforms. Then convert it to a HOST_WIDE_INT like above. */
3197 n
= wi::abs (wrhs
).to_shwi ();
3199 type
= TREE_TYPE (lhs
);
3200 sgn
= tree_int_cst_sgn (rhs
);
3202 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3203 || optimize_size
) && (m
> 2 || m
< -1))
3209 se
->expr
= gfc_build_const (type
, integer_one_node
);
3213 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3214 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3216 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3217 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3218 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3219 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3222 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3225 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3226 logical_type_node
, tmp
, cond
);
3227 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3228 tmp
, build_int_cst (type
, 1),
3229 build_int_cst (type
, 0));
3233 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3234 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3235 build_int_cst (type
, -1),
3236 build_int_cst (type
, 0));
3237 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3238 cond
, build_int_cst (type
, 1), tmp
);
3242 memset (vartmp
, 0, sizeof (vartmp
));
3246 tmp
= gfc_build_const (type
, integer_one_node
);
3247 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3251 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3257 /* Power op (**). Constant integer exponent has special handling. */
3260 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3262 tree gfc_int4_type_node
;
3265 int res_ikind_1
, res_ikind_2
;
3270 gfc_init_se (&lse
, se
);
3271 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3272 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3273 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3275 gfc_init_se (&rse
, se
);
3276 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3277 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3279 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3280 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3281 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3284 if (INTEGER_CST_P (lse
.expr
)
3285 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3287 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3289 int kind
, ikind
, bit_size
;
3291 v
= wlhs
.to_shwi ();
3294 kind
= expr
->value
.op
.op1
->ts
.kind
;
3295 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3296 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3300 /* 1**something is always 1. */
3301 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3306 /* (-1)**n is 1 - ((n & 1) << 1) */
3310 type
= TREE_TYPE (lse
.expr
);
3311 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3312 rse
.expr
, build_int_cst (type
, 1));
3313 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3314 tmp
, build_int_cst (type
, 1));
3315 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3316 build_int_cst (type
, 1), tmp
);
3320 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3322 /* Here v is +/- 2**e. The further simplification uses
3323 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3324 1<<(4*n), etc., but we have to make sure to return zero
3325 if the number of bits is too large. */
3335 type
= TREE_TYPE (lse
.expr
);
3340 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3341 TREE_TYPE (rse
.expr
),
3342 rse
.expr
, rse
.expr
);
3345 /* use popcount for fast log2(w) */
3346 int e
= wi::popcount (w
-1);
3347 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3348 TREE_TYPE (rse
.expr
),
3349 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3353 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3354 build_int_cst (type
, 1), shift
);
3355 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3356 rse
.expr
, build_int_cst (type
, 0));
3357 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3358 build_int_cst (type
, 0));
3359 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3360 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3361 rse
.expr
, num_bits
);
3362 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3363 build_int_cst (type
, 0), cond
);
3370 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3372 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3373 rse
.expr
, build_int_cst (type
, 1));
3374 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3375 tmp2
, build_int_cst (type
, 1));
3376 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3377 build_int_cst (type
, 1), tmp2
);
3378 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3385 gfc_int4_type_node
= gfc_get_int_type (4);
3387 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3388 library routine. But in the end, we have to convert the result back
3389 if this case applies -- with res_ikind_K, we keep track whether operand K
3390 falls into this case. */
3394 kind
= expr
->value
.op
.op1
->ts
.kind
;
3395 switch (expr
->value
.op
.op2
->ts
.type
)
3398 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3403 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3404 res_ikind_2
= ikind
;
3426 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3428 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3455 switch (expr
->value
.op
.op1
->ts
.type
)
3458 if (kind
== 3) /* Case 16 was not handled properly above. */
3460 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3464 /* Use builtins for real ** int4. */
3470 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3474 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3478 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3482 /* Use the __builtin_powil() only if real(kind=16) is
3483 actually the C long double type. */
3484 if (!gfc_real16_is_float128
)
3485 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3493 /* If we don't have a good builtin for this, go for the
3494 library function. */
3496 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3500 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3509 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3513 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3521 se
->expr
= build_call_expr_loc (input_location
,
3522 fndecl
, 2, lse
.expr
, rse
.expr
);
3524 /* Convert the result back if it is of wrong integer kind. */
3525 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3527 /* We want the maximum of both operand kinds as result. */
3528 if (res_ikind_1
< res_ikind_2
)
3529 res_ikind_1
= res_ikind_2
;
3530 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3535 /* Generate code to allocate a string temporary. */
3538 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3543 if (gfc_can_put_var_on_stack (len
))
3545 /* Create a temporary variable to hold the result. */
3546 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3547 TREE_TYPE (len
), len
,
3548 build_int_cst (TREE_TYPE (len
), 1));
3549 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3551 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3552 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3554 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3556 var
= gfc_create_var (tmp
, "str");
3557 var
= gfc_build_addr_expr (type
, var
);
3561 /* Allocate a temporary to hold the result. */
3562 var
= gfc_create_var (type
, "pstr");
3563 gcc_assert (POINTER_TYPE_P (type
));
3564 tmp
= TREE_TYPE (type
);
3565 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3566 tmp
= TREE_TYPE (tmp
);
3567 tmp
= TYPE_SIZE_UNIT (tmp
);
3568 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3569 fold_convert (size_type_node
, len
),
3570 fold_convert (size_type_node
, tmp
));
3571 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3572 gfc_add_modify (&se
->pre
, var
, tmp
);
3574 /* Free the temporary afterwards. */
3575 tmp
= gfc_call_free (var
);
3576 gfc_add_expr_to_block (&se
->post
, tmp
);
3583 /* Handle a string concatenation operation. A temporary will be allocated to
3587 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3590 tree len
, type
, var
, tmp
, fndecl
;
3592 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3593 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3594 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3596 gfc_init_se (&lse
, se
);
3597 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3598 gfc_conv_string_parameter (&lse
);
3599 gfc_init_se (&rse
, se
);
3600 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3601 gfc_conv_string_parameter (&rse
);
3603 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3604 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3606 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3607 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3608 if (len
== NULL_TREE
)
3610 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3611 gfc_charlen_type_node
,
3612 fold_convert (gfc_charlen_type_node
,
3614 fold_convert (gfc_charlen_type_node
,
3615 rse
.string_length
));
3618 type
= build_pointer_type (type
);
3620 var
= gfc_conv_string_tmp (se
, type
, len
);
3622 /* Do the actual concatenation. */
3623 if (expr
->ts
.kind
== 1)
3624 fndecl
= gfor_fndecl_concat_string
;
3625 else if (expr
->ts
.kind
== 4)
3626 fndecl
= gfor_fndecl_concat_string_char4
;
3630 tmp
= build_call_expr_loc (input_location
,
3631 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3632 rse
.string_length
, rse
.expr
);
3633 gfc_add_expr_to_block (&se
->pre
, tmp
);
3635 /* Add the cleanup for the operands. */
3636 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3637 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3640 se
->string_length
= len
;
3643 /* Translates an op expression. Common (binary) cases are handled by this
3644 function, others are passed on. Recursion is used in either case.
3645 We use the fact that (op1.ts == op2.ts) (except for the power
3647 Operators need no special handling for scalarized expressions as long as
3648 they call gfc_conv_simple_val to get their operands.
3649 Character strings get special handling. */
3652 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3654 enum tree_code code
;
3663 switch (expr
->value
.op
.op
)
3665 case INTRINSIC_PARENTHESES
:
3666 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3667 && flag_protect_parens
)
3669 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3670 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3675 case INTRINSIC_UPLUS
:
3676 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3679 case INTRINSIC_UMINUS
:
3680 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3684 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3687 case INTRINSIC_PLUS
:
3691 case INTRINSIC_MINUS
:
3695 case INTRINSIC_TIMES
:
3699 case INTRINSIC_DIVIDE
:
3700 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3701 an integer, we must round towards zero, so we use a
3703 if (expr
->ts
.type
== BT_INTEGER
)
3704 code
= TRUNC_DIV_EXPR
;
3709 case INTRINSIC_POWER
:
3710 gfc_conv_power_op (se
, expr
);
3713 case INTRINSIC_CONCAT
:
3714 gfc_conv_concat_op (se
, expr
);
3718 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3723 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3727 /* EQV and NEQV only work on logicals, but since we represent them
3728 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3730 case INTRINSIC_EQ_OS
:
3738 case INTRINSIC_NE_OS
:
3739 case INTRINSIC_NEQV
:
3746 case INTRINSIC_GT_OS
:
3753 case INTRINSIC_GE_OS
:
3760 case INTRINSIC_LT_OS
:
3767 case INTRINSIC_LE_OS
:
3773 case INTRINSIC_USER
:
3774 case INTRINSIC_ASSIGN
:
3775 /* These should be converted into function calls by the frontend. */
3779 fatal_error (input_location
, "Unknown intrinsic op");
3783 /* The only exception to this is **, which is handled separately anyway. */
3784 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3786 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3790 gfc_init_se (&lse
, se
);
3791 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3792 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3795 gfc_init_se (&rse
, se
);
3796 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3797 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3801 gfc_conv_string_parameter (&lse
);
3802 gfc_conv_string_parameter (&rse
);
3804 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3805 rse
.string_length
, rse
.expr
,
3806 expr
->value
.op
.op1
->ts
.kind
,
3808 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3809 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3812 type
= gfc_typenode_for_spec (&expr
->ts
);
3816 /* The result of logical ops is always logical_type_node. */
3817 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3818 lse
.expr
, rse
.expr
);
3819 se
->expr
= convert (type
, tmp
);
3822 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3824 /* Add the post blocks. */
3825 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3826 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3829 /* If a string's length is one, we convert it to a single character. */
3832 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3836 || !tree_fits_uhwi_p (len
)
3837 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3840 if (TREE_INT_CST_LOW (len
) == 1)
3842 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3843 return build_fold_indirect_ref_loc (input_location
, str
);
3847 && TREE_CODE (str
) == ADDR_EXPR
3848 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3849 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3850 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3851 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3852 && TREE_INT_CST_LOW (len
) > 1
3853 && TREE_INT_CST_LOW (len
)
3854 == (unsigned HOST_WIDE_INT
)
3855 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3857 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3858 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3859 if (TREE_CODE (ret
) == INTEGER_CST
)
3861 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3862 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3863 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3865 for (i
= 1; i
< length
; i
++)
3878 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3881 if (sym
->backend_decl
)
3883 /* This becomes the nominal_type in
3884 function.c:assign_parm_find_data_types. */
3885 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3886 /* This becomes the passed_type in
3887 function.c:assign_parm_find_data_types. C promotes char to
3888 integer for argument passing. */
3889 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3891 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3896 /* If we have a constant character expression, make it into an
3898 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3903 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3904 (int)(*expr
)->value
.character
.string
[0]);
3905 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3907 /* The expr needs to be compatible with a C int. If the
3908 conversion fails, then the 2 causes an ICE. */
3909 ts
.type
= BT_INTEGER
;
3910 ts
.kind
= gfc_c_int_kind
;
3911 gfc_convert_type (*expr
, &ts
, 2);
3914 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3916 if ((*expr
)->ref
== NULL
)
3918 se
->expr
= gfc_string_to_single_character
3919 (build_int_cst (integer_type_node
, 1),
3920 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3922 ((*expr
)->symtree
->n
.sym
)),
3927 gfc_conv_variable (se
, *expr
);
3928 se
->expr
= gfc_string_to_single_character
3929 (build_int_cst (integer_type_node
, 1),
3930 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3938 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3939 if STR is a string literal, otherwise return -1. */
3942 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3945 && TREE_CODE (str
) == ADDR_EXPR
3946 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3947 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3948 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3949 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3950 && tree_fits_uhwi_p (len
)
3951 && tree_to_uhwi (len
) >= 1
3952 && tree_to_uhwi (len
)
3953 == (unsigned HOST_WIDE_INT
)
3954 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3956 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3957 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3958 if (TREE_CODE (folded
) == INTEGER_CST
)
3960 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3961 int length
= TREE_STRING_LENGTH (string_cst
);
3962 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3964 for (; length
> 0; length
--)
3965 if (ptr
[length
- 1] != ' ')
3974 /* Helper to build a call to memcmp. */
3977 build_memcmp_call (tree s1
, tree s2
, tree n
)
3981 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3982 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3984 s1
= fold_convert (pvoid_type_node
, s1
);
3986 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3987 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3989 s2
= fold_convert (pvoid_type_node
, s2
);
3991 n
= fold_convert (size_type_node
, n
);
3993 tmp
= build_call_expr_loc (input_location
,
3994 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3997 return fold_convert (integer_type_node
, tmp
);
4000 /* Compare two strings. If they are all single characters, the result is the
4001 subtraction of them. Otherwise, we build a library call. */
4004 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
4005 enum tree_code code
)
4011 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
4012 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
4014 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
4015 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
4017 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
4019 /* Deal with single character specially. */
4020 sc1
= fold_convert (integer_type_node
, sc1
);
4021 sc2
= fold_convert (integer_type_node
, sc2
);
4022 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4026 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
4028 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
4030 /* If one string is a string literal with LEN_TRIM longer
4031 than the length of the second string, the strings
4033 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
4034 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
4035 return integer_one_node
;
4036 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
4037 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
4038 return integer_one_node
;
4041 /* We can compare via memcpy if the strings are known to be equal
4042 in length and they are
4044 - kind=4 and the comparison is for (in)equality. */
4046 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
4047 && tree_int_cst_equal (len1
, len2
)
4048 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
4053 chartype
= gfc_get_char_type (kind
);
4054 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
4055 fold_convert (TREE_TYPE(len1
),
4056 TYPE_SIZE_UNIT(chartype
)),
4058 return build_memcmp_call (str1
, str2
, tmp
);
4061 /* Build a call for the comparison. */
4063 fndecl
= gfor_fndecl_compare_string
;
4065 fndecl
= gfor_fndecl_compare_string_char4
;
4069 return build_call_expr_loc (input_location
, fndecl
, 4,
4070 len1
, str1
, len2
, str2
);
4074 /* Return the backend_decl for a procedure pointer component. */
4077 get_proc_ptr_comp (gfc_expr
*e
)
4083 gfc_init_se (&comp_se
, NULL
);
4084 e2
= gfc_copy_expr (e
);
4085 /* We have to restore the expr type later so that gfc_free_expr frees
4086 the exact same thing that was allocated.
4087 TODO: This is ugly. */
4088 old_type
= e2
->expr_type
;
4089 e2
->expr_type
= EXPR_VARIABLE
;
4090 gfc_conv_expr (&comp_se
, e2
);
4091 e2
->expr_type
= old_type
;
4093 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
4097 /* Convert a typebound function reference from a class object. */
4099 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
4104 if (!VAR_P (base_object
))
4106 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
4107 gfc_add_modify (&se
->pre
, var
, base_object
);
4109 se
->expr
= gfc_class_vptr_get (base_object
);
4110 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4112 while (ref
&& ref
->next
)
4114 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
4115 if (ref
->u
.c
.sym
->attr
.extension
)
4116 conv_parent_component_references (se
, ref
);
4117 gfc_conv_component_ref (se
, ref
);
4118 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
4123 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
4124 gfc_actual_arglist
*actual_args
)
4128 if (gfc_is_proc_ptr_comp (expr
))
4129 tmp
= get_proc_ptr_comp (expr
);
4130 else if (sym
->attr
.dummy
)
4132 tmp
= gfc_get_symbol_decl (sym
);
4133 if (sym
->attr
.proc_pointer
)
4134 tmp
= build_fold_indirect_ref_loc (input_location
,
4136 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
4137 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
4141 if (!sym
->backend_decl
)
4142 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
4144 TREE_USED (sym
->backend_decl
) = 1;
4146 tmp
= sym
->backend_decl
;
4148 if (sym
->attr
.cray_pointee
)
4150 /* TODO - make the cray pointee a pointer to a procedure,
4151 assign the pointer to it and use it for the call. This
4153 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
4154 gfc_get_symbol_decl (sym
->cp_pointer
));
4155 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4158 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
4160 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
4161 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4168 /* Initialize MAPPING. */
4171 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
4173 mapping
->syms
= NULL
;
4174 mapping
->charlens
= NULL
;
4178 /* Free all memory held by MAPPING (but not MAPPING itself). */
4181 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4183 gfc_interface_sym_mapping
*sym
;
4184 gfc_interface_sym_mapping
*nextsym
;
4186 gfc_charlen
*nextcl
;
4188 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4190 nextsym
= sym
->next
;
4191 sym
->new_sym
->n
.sym
->formal
= NULL
;
4192 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4193 gfc_free_expr (sym
->expr
);
4194 free (sym
->new_sym
);
4197 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4200 gfc_free_expr (cl
->length
);
4206 /* Return a copy of gfc_charlen CL. Add the returned structure to
4207 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4209 static gfc_charlen
*
4210 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4213 gfc_charlen
*new_charlen
;
4215 new_charlen
= gfc_get_charlen ();
4216 new_charlen
->next
= mapping
->charlens
;
4217 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4219 mapping
->charlens
= new_charlen
;
4224 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4225 array variable that can be used as the actual argument for dummy
4226 argument SYM. Add any initialization code to BLOCK. PACKED is as
4227 for gfc_get_nodesc_array_type and DATA points to the first element
4228 in the passed array. */
4231 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4232 gfc_packed packed
, tree data
)
4237 type
= gfc_typenode_for_spec (&sym
->ts
);
4238 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4239 !sym
->attr
.target
&& !sym
->attr
.pointer
4240 && !sym
->attr
.proc_pointer
);
4242 var
= gfc_create_var (type
, "ifm");
4243 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4249 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4250 and offset of descriptorless array type TYPE given that it has the same
4251 size as DESC. Add any set-up code to BLOCK. */
4254 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4261 offset
= gfc_index_zero_node
;
4262 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4264 dim
= gfc_rank_cst
[n
];
4265 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4266 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4268 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4269 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4270 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4271 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4273 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4275 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4276 gfc_array_index_type
,
4277 gfc_conv_descriptor_ubound_get (desc
, dim
),
4278 gfc_conv_descriptor_lbound_get (desc
, dim
));
4279 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4280 gfc_array_index_type
,
4281 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4282 tmp
= gfc_evaluate_now (tmp
, block
);
4283 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4285 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4286 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4287 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4288 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4289 gfc_array_index_type
, offset
, tmp
);
4291 offset
= gfc_evaluate_now (offset
, block
);
4292 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4296 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4297 in SE. The caller may still use se->expr and se->string_length after
4298 calling this function. */
4301 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4302 gfc_symbol
* sym
, gfc_se
* se
,
4305 gfc_interface_sym_mapping
*sm
;
4309 gfc_symbol
*new_sym
;
4311 gfc_symtree
*new_symtree
;
4313 /* Create a new symbol to represent the actual argument. */
4314 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4315 new_sym
->ts
= sym
->ts
;
4316 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4317 new_sym
->attr
.referenced
= 1;
4318 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4319 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4320 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4321 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4322 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4323 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4324 new_sym
->attr
.function
= sym
->attr
.function
;
4326 /* Ensure that the interface is available and that
4327 descriptors are passed for array actual arguments. */
4328 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4330 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4331 new_sym
->attr
.always_explicit
4332 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4335 /* Create a fake symtree for it. */
4337 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4338 new_symtree
->n
.sym
= new_sym
;
4339 gcc_assert (new_symtree
== root
);
4341 /* Create a dummy->actual mapping. */
4342 sm
= XCNEW (gfc_interface_sym_mapping
);
4343 sm
->next
= mapping
->syms
;
4345 sm
->new_sym
= new_symtree
;
4346 sm
->expr
= gfc_copy_expr (expr
);
4349 /* Stabilize the argument's value. */
4350 if (!sym
->attr
.function
&& se
)
4351 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4353 if (sym
->ts
.type
== BT_CHARACTER
)
4355 /* Create a copy of the dummy argument's length. */
4356 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4357 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4359 /* If the length is specified as "*", record the length that
4360 the caller is passing. We should use the callee's length
4361 in all other cases. */
4362 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4364 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4365 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4372 /* Use the passed value as-is if the argument is a function. */
4373 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4376 /* If the argument is a pass-by-value scalar, use the value as is. */
4377 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4380 /* If the argument is either a string or a pointer to a string,
4381 convert it to a boundless character type. */
4382 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4384 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4385 tmp
= build_pointer_type (tmp
);
4386 if (sym
->attr
.pointer
)
4387 value
= build_fold_indirect_ref_loc (input_location
,
4391 value
= fold_convert (tmp
, value
);
4394 /* If the argument is a scalar, a pointer to an array or an allocatable,
4396 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4397 value
= build_fold_indirect_ref_loc (input_location
,
4400 /* For character(*), use the actual argument's descriptor. */
4401 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4402 value
= build_fold_indirect_ref_loc (input_location
,
4405 /* If the argument is an array descriptor, use it to determine
4406 information about the actual argument's shape. */
4407 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4408 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4410 /* Get the actual argument's descriptor. */
4411 desc
= build_fold_indirect_ref_loc (input_location
,
4414 /* Create the replacement variable. */
4415 tmp
= gfc_conv_descriptor_data_get (desc
);
4416 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4419 /* Use DESC to work out the upper bounds, strides and offset. */
4420 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4423 /* Otherwise we have a packed array. */
4424 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4425 PACKED_FULL
, se
->expr
);
4427 new_sym
->backend_decl
= value
;
4431 /* Called once all dummy argument mappings have been added to MAPPING,
4432 but before the mapping is used to evaluate expressions. Pre-evaluate
4433 the length of each argument, adding any initialization code to PRE and
4434 any finalization code to POST. */
4437 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4438 stmtblock_t
* pre
, stmtblock_t
* post
)
4440 gfc_interface_sym_mapping
*sym
;
4444 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4445 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4446 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4448 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4449 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4450 gfc_init_se (&se
, NULL
);
4451 gfc_conv_expr (&se
, expr
);
4452 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4453 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4454 gfc_add_block_to_block (pre
, &se
.pre
);
4455 gfc_add_block_to_block (post
, &se
.post
);
4457 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4462 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4466 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4467 gfc_constructor_base base
)
4470 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4472 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4475 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4476 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4477 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4483 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4487 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4492 for (; ref
; ref
= ref
->next
)
4496 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4498 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4499 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4500 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4509 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4510 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4516 /* Convert intrinsic function calls into result expressions. */
4519 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4527 arg1
= expr
->value
.function
.actual
->expr
;
4528 if (expr
->value
.function
.actual
->next
)
4529 arg2
= expr
->value
.function
.actual
->next
->expr
;
4533 sym
= arg1
->symtree
->n
.sym
;
4535 if (sym
->attr
.dummy
)
4540 switch (expr
->value
.function
.isym
->id
)
4543 /* TODO figure out why this condition is necessary. */
4544 if (sym
->attr
.function
4545 && (arg1
->ts
.u
.cl
->length
== NULL
4546 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4547 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4550 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4553 case GFC_ISYM_LEN_TRIM
:
4554 new_expr
= gfc_copy_expr (arg1
);
4555 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4560 gfc_replace_expr (arg1
, new_expr
);
4564 if (!sym
->as
|| sym
->as
->rank
== 0)
4567 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4569 dup
= mpz_get_si (arg2
->value
.integer
);
4574 dup
= sym
->as
->rank
;
4578 for (; d
< dup
; d
++)
4582 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4584 gfc_free_expr (new_expr
);
4588 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4589 gfc_get_int_expr (gfc_default_integer_kind
,
4591 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4593 new_expr
= gfc_multiply (new_expr
, tmp
);
4599 case GFC_ISYM_LBOUND
:
4600 case GFC_ISYM_UBOUND
:
4601 /* TODO These implementations of lbound and ubound do not limit if
4602 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4604 if (!sym
->as
|| sym
->as
->rank
== 0)
4607 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4608 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4612 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4614 if (sym
->as
->lower
[d
])
4615 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4619 if (sym
->as
->upper
[d
])
4620 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4628 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4632 gfc_replace_expr (expr
, new_expr
);
4638 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4639 gfc_interface_mapping
* mapping
)
4641 gfc_formal_arglist
*f
;
4642 gfc_actual_arglist
*actual
;
4644 actual
= expr
->value
.function
.actual
;
4645 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4647 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4652 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4655 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4660 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4662 for (d
= 0; d
< as
->rank
; d
++)
4664 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4665 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4668 expr
->value
.function
.esym
->as
= as
;
4671 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4673 expr
->value
.function
.esym
->ts
.u
.cl
->length
4674 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4676 gfc_apply_interface_mapping_to_expr (mapping
,
4677 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4682 /* EXPR is a copy of an expression that appeared in the interface
4683 associated with MAPPING. Walk it recursively looking for references to
4684 dummy arguments that MAPPING maps to actual arguments. Replace each such
4685 reference with a reference to the associated actual argument. */
4688 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4691 gfc_interface_sym_mapping
*sym
;
4692 gfc_actual_arglist
*actual
;
4697 /* Copying an expression does not copy its length, so do that here. */
4698 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4700 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4701 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4704 /* Apply the mapping to any references. */
4705 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4707 /* ...and to the expression's symbol, if it has one. */
4708 /* TODO Find out why the condition on expr->symtree had to be moved into
4709 the loop rather than being outside it, as originally. */
4710 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4711 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4713 if (sym
->new_sym
->n
.sym
->backend_decl
)
4714 expr
->symtree
= sym
->new_sym
;
4716 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4719 /* ...and to subexpressions in expr->value. */
4720 switch (expr
->expr_type
)
4725 case EXPR_SUBSTRING
:
4729 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4730 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4734 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4735 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4737 if (expr
->value
.function
.esym
== NULL
4738 && expr
->value
.function
.isym
!= NULL
4739 && expr
->value
.function
.actual
4740 && expr
->value
.function
.actual
->expr
4741 && expr
->value
.function
.actual
->expr
->symtree
4742 && gfc_map_intrinsic_function (expr
, mapping
))
4745 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4746 if (sym
->old
== expr
->value
.function
.esym
)
4748 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4749 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4750 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4755 case EXPR_STRUCTURE
:
4756 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4770 /* Evaluate interface expression EXPR using MAPPING. Store the result
4774 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4775 gfc_se
* se
, gfc_expr
* expr
)
4777 expr
= gfc_copy_expr (expr
);
4778 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4779 gfc_conv_expr (se
, expr
);
4780 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4781 gfc_free_expr (expr
);
4785 /* Returns a reference to a temporary array into which a component of
4786 an actual argument derived type array is copied and then returned
4787 after the function call. */
4789 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4790 sym_intent intent
, bool formal_ptr
,
4791 const gfc_symbol
*fsym
, const char *proc_name
,
4792 gfc_symbol
*sym
, bool check_contiguous
)
4800 gfc_array_info
*info
;
4813 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4815 if (pass_optional
|| check_contiguous
)
4817 gfc_init_se (&work_se
, NULL
);
4823 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4825 /* We will create a temporary array, so let us warn. */
4828 if (fsym
&& proc_name
)
4829 msg
= xasprintf ("An array temporary was created for argument "
4830 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4832 msg
= xasprintf ("An array temporary was created");
4834 tmp
= build_int_cst (logical_type_node
, 1);
4835 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4840 gfc_init_se (&lse
, NULL
);
4841 gfc_init_se (&rse
, NULL
);
4843 /* Walk the argument expression. */
4844 rss
= gfc_walk_expr (expr
);
4846 gcc_assert (rss
!= gfc_ss_terminator
);
4848 /* Initialize the scalarizer. */
4849 gfc_init_loopinfo (&loop
);
4850 gfc_add_ss_to_loop (&loop
, rss
);
4852 /* Calculate the bounds of the scalarization. */
4853 gfc_conv_ss_startstride (&loop
);
4855 /* Build an ss for the temporary. */
4856 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4857 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4859 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4860 if (GFC_ARRAY_TYPE_P (base_type
)
4861 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4862 base_type
= gfc_get_element_type (base_type
);
4864 if (expr
->ts
.type
== BT_CLASS
)
4865 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4867 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4868 ? expr
->ts
.u
.cl
->backend_decl
4872 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4874 /* Associate the SS with the loop. */
4875 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4877 /* Setup the scalarizing loops. */
4878 gfc_conv_loop_setup (&loop
, &expr
->where
);
4880 /* Pass the temporary descriptor back to the caller. */
4881 info
= &loop
.temp_ss
->info
->data
.array
;
4882 parmse
->expr
= info
->descriptor
;
4884 /* Setup the gfc_se structures. */
4885 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4886 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4889 lse
.ss
= loop
.temp_ss
;
4890 gfc_mark_ss_chain_used (rss
, 1);
4891 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4893 /* Start the scalarized loop body. */
4894 gfc_start_scalarized_body (&loop
, &body
);
4896 /* Translate the expression. */
4897 gfc_conv_expr (&rse
, expr
);
4899 /* Reset the offset for the function call since the loop
4900 is zero based on the data pointer. Note that the temp
4901 comes first in the loop chain since it is added second. */
4902 if (gfc_is_class_array_function (expr
))
4904 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4905 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4906 gfc_index_zero_node
);
4909 gfc_conv_tmp_array_ref (&lse
);
4911 if (intent
!= INTENT_OUT
)
4913 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4914 gfc_add_expr_to_block (&body
, tmp
);
4915 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4916 gfc_trans_scalarizing_loops (&loop
, &body
);
4920 /* Make sure that the temporary declaration survives by merging
4921 all the loop declarations into the current context. */
4922 for (n
= 0; n
< loop
.dimen
; n
++)
4924 gfc_merge_block_scope (&body
);
4925 body
= loop
.code
[loop
.order
[n
]];
4927 gfc_merge_block_scope (&body
);
4930 /* Add the post block after the second loop, so that any
4931 freeing of allocated memory is done at the right time. */
4932 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4934 /**********Copy the temporary back again.*********/
4936 gfc_init_se (&lse
, NULL
);
4937 gfc_init_se (&rse
, NULL
);
4939 /* Walk the argument expression. */
4940 lss
= gfc_walk_expr (expr
);
4941 rse
.ss
= loop
.temp_ss
;
4944 /* Initialize the scalarizer. */
4945 gfc_init_loopinfo (&loop2
);
4946 gfc_add_ss_to_loop (&loop2
, lss
);
4948 dimen
= rse
.ss
->dimen
;
4950 /* Skip the write-out loop for this case. */
4951 if (gfc_is_class_array_function (expr
))
4952 goto class_array_fcn
;
4954 /* Calculate the bounds of the scalarization. */
4955 gfc_conv_ss_startstride (&loop2
);
4957 /* Setup the scalarizing loops. */
4958 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4960 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4961 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4963 gfc_mark_ss_chain_used (lss
, 1);
4964 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4966 /* Declare the variable to hold the temporary offset and start the
4967 scalarized loop body. */
4968 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4969 gfc_start_scalarized_body (&loop2
, &body
);
4971 /* Build the offsets for the temporary from the loop variables. The
4972 temporary array has lbounds of zero and strides of one in all
4973 dimensions, so this is very simple. The offset is only computed
4974 outside the innermost loop, so the overall transfer could be
4975 optimized further. */
4976 info
= &rse
.ss
->info
->data
.array
;
4978 tmp_index
= gfc_index_zero_node
;
4979 for (n
= dimen
- 1; n
> 0; n
--)
4982 tmp
= rse
.loop
->loopvar
[n
];
4983 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4984 tmp
, rse
.loop
->from
[n
]);
4985 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4988 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4989 gfc_array_index_type
,
4990 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4991 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4992 gfc_array_index_type
,
4993 tmp_str
, gfc_index_one_node
);
4995 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4996 gfc_array_index_type
, tmp
, tmp_str
);
4999 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
5000 gfc_array_index_type
,
5001 tmp_index
, rse
.loop
->from
[0]);
5002 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
5004 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5005 gfc_array_index_type
,
5006 rse
.loop
->loopvar
[0], offset
);
5008 /* Now use the offset for the reference. */
5009 tmp
= build_fold_indirect_ref_loc (input_location
,
5011 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
5013 if (expr
->ts
.type
== BT_CHARACTER
)
5014 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
5016 gfc_conv_expr (&lse
, expr
);
5018 gcc_assert (lse
.ss
== gfc_ss_terminator
);
5020 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
5021 gfc_add_expr_to_block (&body
, tmp
);
5023 /* Generate the copying loops. */
5024 gfc_trans_scalarizing_loops (&loop2
, &body
);
5026 /* Wrap the whole thing up by adding the second loop to the post-block
5027 and following it by the post-block of the first loop. In this way,
5028 if the temporary needs freeing, it is done after use! */
5029 if (intent
!= INTENT_IN
)
5031 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
5032 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
5037 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
5039 gfc_cleanup_loop (&loop
);
5040 gfc_cleanup_loop (&loop2
);
5042 /* Pass the string length to the argument expression. */
5043 if (expr
->ts
.type
== BT_CHARACTER
)
5044 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5046 /* Determine the offset for pointer formal arguments and set the
5050 size
= gfc_index_one_node
;
5051 offset
= gfc_index_zero_node
;
5052 for (n
= 0; n
< dimen
; n
++)
5054 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
5056 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5057 gfc_array_index_type
, tmp
,
5058 gfc_index_one_node
);
5059 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
5063 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
5066 gfc_index_one_node
);
5067 size
= gfc_evaluate_now (size
, &parmse
->pre
);
5068 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5069 gfc_array_index_type
,
5071 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
5072 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5073 gfc_array_index_type
,
5074 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
5075 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5076 gfc_array_index_type
,
5077 tmp
, gfc_index_one_node
);
5078 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5079 gfc_array_index_type
, size
, tmp
);
5082 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
5086 /* We want either the address for the data or the address of the descriptor,
5087 depending on the mode of passing array arguments. */
5089 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
5091 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5093 /* Basically make this into
5104 pointer = parmse->expr;
5111 if (present && !contiguous)
5116 if (pass_optional
|| check_contiguous
)
5119 stmtblock_t else_block
;
5120 tree pre_stmts
, post_stmts
;
5123 tree present_var
= NULL_TREE
;
5124 tree cont_var
= NULL_TREE
;
5127 type
= TREE_TYPE (parmse
->expr
);
5128 pointer
= gfc_create_var (type
, "arg_ptr");
5130 if (check_contiguous
)
5132 gfc_se cont_se
, array_se
;
5133 stmtblock_t if_block
, else_block
;
5134 tree if_stmt
, else_stmt
;
5138 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
5140 /* If the size is known to be one at compile-time, set
5141 cont_var to true unconditionally. This may look
5142 inelegant, but we're only doing this during
5143 optimization, so the statements will be optimized away,
5144 and this saves complexity here. */
5146 size_set
= gfc_array_size (expr
, &size
);
5147 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
5149 gfc_add_modify (&se
->pre
, cont_var
,
5150 build_one_cst (boolean_type_node
));
5154 /* cont_var = is_contiguous (expr); . */
5155 gfc_init_se (&cont_se
, parmse
);
5156 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
5157 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
5158 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
5159 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
5165 /* arrayse->expr = descriptor of a. */
5166 gfc_init_se (&array_se
, se
);
5167 gfc_conv_expr_descriptor (&array_se
, expr
);
5168 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
5169 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
5171 /* if_stmt = { pointer = &a[0]; } . */
5172 gfc_init_block (&if_block
);
5173 tmp
= gfc_conv_array_data (array_se
.expr
);
5174 tmp
= fold_convert (type
, tmp
);
5175 gfc_add_modify (&if_block
, pointer
, tmp
);
5176 if_stmt
= gfc_finish_block (&if_block
);
5178 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5179 gfc_init_block (&else_block
);
5180 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
5181 gfc_add_modify (&else_block
, pointer
, parmse
->expr
);
5182 else_stmt
= gfc_finish_block (&else_block
);
5184 /* And put the above into an if statement. */
5185 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5186 gfc_likely (cont_var
,
5187 PRED_FORTRAN_CONTIGUOUS
),
5188 if_stmt
, else_stmt
);
5192 /* pointer = pramse->expr; . */
5193 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5194 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5199 present_var
= gfc_create_var (boolean_type_node
, "present");
5201 /* present_var = present(sym); . */
5202 tmp
= gfc_conv_expr_present (sym
);
5203 tmp
= fold_convert (boolean_type_node
, tmp
);
5204 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5206 /* else_stmt = { pointer = NULL; } . */
5207 gfc_init_block (&else_block
);
5208 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5209 else_stmt
= gfc_finish_block (&else_block
);
5211 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5212 gfc_likely (present_var
,
5213 PRED_FORTRAN_ABSENT_DUMMY
),
5214 pre_stmts
, else_stmt
);
5215 gfc_add_expr_to_block (&se
->pre
, tmp
);
5218 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5220 post_stmts
= gfc_finish_block (&parmse
->post
);
5222 /* Put together the post stuff, plus the optional
5224 if (check_contiguous
)
5227 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5229 build_zero_cst (boolean_type_node
));
5230 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5234 tree present_likely
= gfc_likely (present_var
,
5235 PRED_FORTRAN_ABSENT_DUMMY
);
5236 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5237 boolean_type_node
, present_likely
,
5245 gcc_assert (pass_optional
);
5246 post_cond
= present_var
;
5249 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5250 post_stmts
, build_empty_stmt (input_location
));
5251 gfc_add_expr_to_block (&se
->post
, tmp
);
5259 /* Generate the code for argument list functions. */
5262 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5264 /* Pass by value for g77 %VAL(arg), pass the address
5265 indirectly for %LOC, else by reference. Thus %REF
5266 is a "do-nothing" and %LOC is the same as an F95
5268 if (strcmp (name
, "%VAL") == 0)
5269 gfc_conv_expr (se
, expr
);
5270 else if (strcmp (name
, "%LOC") == 0)
5272 gfc_conv_expr_reference (se
, expr
);
5273 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5275 else if (strcmp (name
, "%REF") == 0)
5276 gfc_conv_expr_reference (se
, expr
);
5278 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5282 /* This function tells whether the middle-end representation of the expression
5283 E given as input may point to data otherwise accessible through a variable
5285 It is assumed that the only expressions that may alias are variables,
5286 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5288 This function is used to decide whether freeing an expression's allocatable
5289 components is safe or should be avoided.
5291 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5292 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5293 is necessary because for array constructors, aliasing depends on how
5295 - If E is an array constructor used as argument to an elemental procedure,
5296 the array, which is generated through shallow copy by the scalarizer,
5297 is used directly and can alias the expressions it was copied from.
5298 - If E is an array constructor used as argument to a non-elemental
5299 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5300 the array as in the previous case, but then that array is used
5301 to initialize a new descriptor through deep copy. There is no alias
5302 possible in that case.
5303 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5307 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5311 if (e
->expr_type
== EXPR_VARIABLE
)
5313 else if (e
->expr_type
== EXPR_FUNCTION
)
5315 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5317 if (proc_ifc
->result
!= NULL
5318 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5319 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5320 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5321 || proc_ifc
->result
->attr
.pointer
))
5326 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5329 for (c
= gfc_constructor_first (e
->value
.constructor
);
5330 c
; c
= gfc_constructor_next (c
))
5332 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5339 /* A helper function to set the dtype for unallocated or unassociated
5343 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5351 /* TODO Figure out how to handle optional dummies. */
5352 if (e
&& e
->expr_type
== EXPR_VARIABLE
5353 && e
->symtree
->n
.sym
->attr
.optional
)
5356 desc
= parmse
->expr
;
5357 if (desc
== NULL_TREE
)
5360 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5361 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5363 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5366 gfc_init_block (&block
);
5367 tmp
= gfc_conv_descriptor_data_get (desc
);
5368 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5369 logical_type_node
, tmp
,
5370 build_int_cst (TREE_TYPE (tmp
), 0));
5371 tmp
= gfc_conv_descriptor_dtype (desc
);
5372 type
= gfc_get_element_type (TREE_TYPE (desc
));
5373 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5374 TREE_TYPE (tmp
), tmp
,
5375 gfc_get_dtype_rank_type (e
->rank
, type
));
5376 gfc_add_expr_to_block (&block
, tmp
);
5377 cond
= build3_v (COND_EXPR
, cond
,
5378 gfc_finish_block (&block
),
5379 build_empty_stmt (input_location
));
5380 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5385 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5386 ISO_Fortran_binding array descriptors. */
5389 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5399 symbol_attribute attr
= gfc_expr_attr (e
);
5401 /* If this is a full array or a scalar, the allocatable and pointer
5402 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5404 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
5408 else if (attr
.allocatable
)
5412 /* If the formal argument is assumed shape and neither a pointer nor
5413 allocatable, it is unconditionally CFI_attribute_other. */
5414 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
5415 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)
5418 cfi_attribute
= attribute
;
5422 parmse
->force_no_tmp
= 1;
5423 if (fsym
->attr
.contiguous
5424 && !gfc_is_simply_contiguous (e
, false, true))
5425 gfc_conv_subref_array_arg (parmse
, e
, false, fsym
->attr
.intent
,
5426 fsym
->attr
.pointer
);
5428 gfc_conv_expr_descriptor (parmse
, e
);
5430 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5431 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5433 bool is_artificial
= (INDIRECT_REF_P (parmse
->expr
)
5434 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse
->expr
, 0))
5435 : DECL_ARTIFICIAL (parmse
->expr
));
5437 /* Unallocated allocatable arrays and unassociated pointer arrays
5438 need their dtype setting if they are argument associated with
5439 assumed rank dummies. */
5440 if (fsym
&& fsym
->as
5441 && (gfc_expr_attr (e
).pointer
5442 || gfc_expr_attr (e
).allocatable
))
5443 set_dtype_for_unallocated (parmse
, e
);
5445 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5446 the expression type is different from the descriptor type, then
5447 the offset must be found (eg. to a component ref or substring)
5448 and the dtype updated. Assumed type entities are only allowed
5449 to be dummies in Fortran. They therefore lack the decl specific
5450 appendiges and so must be treated differently from other fortran
5451 entities passed to CFI descriptors in the interface decl. */
5452 type
= e
->ts
.type
!= BT_ASSUMED
? gfc_typenode_for_spec (&e
->ts
) :
5455 if (type
&& is_artificial
5456 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
5458 /* Obtain the offset to the data. */
5459 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
5460 gfc_index_zero_node
, true, e
);
5462 /* Update the dtype. */
5463 gfc_add_modify (&parmse
->pre
,
5464 gfc_conv_descriptor_dtype (parmse
->expr
),
5465 gfc_get_dtype_rank_type (e
->rank
, type
));
5467 else if (type
== NULL_TREE
5468 || (!is_subref_array (e
) && !is_artificial
))
5470 /* Make sure that the span is set for expressions where it
5471 might not have been done already. */
5472 tmp
= gfc_conv_descriptor_elem_len (parmse
->expr
);
5473 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5474 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
5479 gfc_conv_expr (parmse
, e
);
5481 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5482 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5485 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
5486 parmse
->expr
, attr
);
5489 /* Set the CFI attribute field through a temporary value for the
5491 desc_attr
= gfc_conv_descriptor_attribute (parmse
->expr
);
5492 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5493 void_type_node
, desc_attr
,
5494 build_int_cst (TREE_TYPE (desc_attr
), cfi_attribute
));
5495 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5497 /* Now pass the gfc_descriptor by reference. */
5498 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5500 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5501 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5502 gfc_desc_ptr
= parmse
->expr
;
5503 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
5504 gfc_add_modify (&parmse
->pre
, cfi_desc_ptr
, null_pointer_node
);
5506 /* Allocate the CFI descriptor itself and fill the fields. */
5507 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
5508 tmp
= build_call_expr_loc (input_location
,
5509 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
5510 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5512 /* Now set the gfc descriptor attribute. */
5513 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5514 void_type_node
, desc_attr
,
5515 build_int_cst (TREE_TYPE (desc_attr
), attribute
));
5516 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5518 /* The CFI descriptor is passed to the bind_C procedure. */
5519 parmse
->expr
= cfi_desc_ptr
;
5521 /* Free the CFI descriptor. */
5522 tmp
= gfc_call_free (cfi_desc_ptr
);
5523 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5525 /* Transfer values back to gfc descriptor. */
5526 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5527 tmp
= build_call_expr_loc (input_location
,
5528 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
5529 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5531 /* Deal with an optional dummy being passed to an optional formal arg
5532 by finishing the pre and post blocks and making their execution
5533 conditional on the dummy being present. */
5534 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5535 && e
->symtree
->n
.sym
->attr
.optional
)
5537 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5538 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5540 build_int_cst (pvoid_type_node
, 0));
5541 tmp
= build3_v (COND_EXPR
, cond
,
5542 gfc_finish_block (&parmse
->pre
), tmp
);
5543 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5544 tmp
= build3_v (COND_EXPR
, cond
,
5545 gfc_finish_block (&parmse
->post
),
5546 build_empty_stmt (input_location
));
5547 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5552 /* Generate code for a procedure call. Note can return se->post != NULL.
5553 If se->direct_byref is set then se->expr contains the return parameter.
5554 Return nonzero, if the call has alternate specifiers.
5555 'expr' is only needed for procedure pointer components. */
5558 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5559 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5560 vec
<tree
, va_gc
> *append_args
)
5562 gfc_interface_mapping mapping
;
5563 vec
<tree
, va_gc
> *arglist
;
5564 vec
<tree
, va_gc
> *retargs
;
5568 gfc_array_info
*info
;
5575 vec
<tree
, va_gc
> *stringargs
;
5576 vec
<tree
, va_gc
> *optionalargs
;
5578 gfc_formal_arglist
*formal
;
5579 gfc_actual_arglist
*arg
;
5580 int has_alternate_specifier
= 0;
5581 bool need_interface_mapping
;
5589 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5590 gfc_component
*comp
= NULL
;
5597 optionalargs
= NULL
;
5602 comp
= gfc_get_proc_ptr_comp (expr
);
5604 bool elemental_proc
= (comp
5605 && comp
->ts
.interface
5606 && comp
->ts
.interface
->attr
.elemental
)
5607 || (comp
&& comp
->attr
.elemental
)
5608 || sym
->attr
.elemental
;
5612 if (!elemental_proc
)
5614 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5615 if (se
->ss
->info
->useflags
)
5617 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5618 && sym
->result
->attr
.dimension
)
5619 || (comp
&& comp
->attr
.dimension
)
5620 || gfc_is_class_array_function (expr
));
5621 gcc_assert (se
->loop
!= NULL
);
5622 /* Access the previously obtained result. */
5623 gfc_conv_tmp_array_ref (se
);
5627 info
= &se
->ss
->info
->data
.array
;
5632 gfc_init_block (&post
);
5633 gfc_init_interface_mapping (&mapping
);
5636 formal
= gfc_sym_get_dummy_args (sym
);
5637 need_interface_mapping
= sym
->attr
.dimension
||
5638 (sym
->ts
.type
== BT_CHARACTER
5639 && sym
->ts
.u
.cl
->length
5640 && sym
->ts
.u
.cl
->length
->expr_type
5645 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5646 need_interface_mapping
= comp
->attr
.dimension
||
5647 (comp
->ts
.type
== BT_CHARACTER
5648 && comp
->ts
.u
.cl
->length
5649 && comp
->ts
.u
.cl
->length
->expr_type
5653 base_object
= NULL_TREE
;
5654 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5655 is the third and fourth argument to such a function call a value
5656 denoting the number of elements to copy (i.e., most of the time the
5657 length of a deferred length string). */
5658 ulim_copy
= (formal
== NULL
)
5659 && UNLIMITED_POLY (sym
)
5660 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5662 /* Evaluate the arguments. */
5663 for (arg
= args
, argc
= 0; arg
!= NULL
;
5664 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5666 bool finalized
= false;
5667 bool non_unity_length_string
= false;
5670 fsym
= formal
? formal
->sym
: NULL
;
5671 parm_kind
= MISSING
;
5673 if (fsym
&& fsym
->ts
.type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
5674 && (!fsym
->ts
.u
.cl
->length
5675 || fsym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5676 || mpz_cmp_si (fsym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5677 non_unity_length_string
= true;
5679 /* If the procedure requires an explicit interface, the actual
5680 argument is passed according to the corresponding formal
5681 argument. If the corresponding formal argument is a POINTER,
5682 ALLOCATABLE or assumed shape, we do not use g77's calling
5683 convention, and pass the address of the array descriptor
5684 instead. Otherwise we use g77's calling convention, in other words
5685 pass the array data pointer without descriptor. */
5686 bool nodesc_arg
= fsym
!= NULL
5687 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5689 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5690 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5692 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5694 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5696 /* Class array expressions are sometimes coming completely unadorned
5697 with either arrayspec or _data component. Correct that here.
5698 OOP-TODO: Move this to the frontend. */
5699 if (e
&& e
->expr_type
== EXPR_VARIABLE
5701 && e
->ts
.type
== BT_CLASS
5702 && (CLASS_DATA (e
)->attr
.codimension
5703 || CLASS_DATA (e
)->attr
.dimension
))
5705 gfc_typespec temp_ts
= e
->ts
;
5706 gfc_add_class_array_ref (e
);
5712 if (se
->ignore_optional
)
5714 /* Some intrinsics have already been resolved to the correct
5718 else if (arg
->label
)
5720 has_alternate_specifier
= 1;
5725 gfc_init_se (&parmse
, NULL
);
5727 /* For scalar arguments with VALUE attribute which are passed by
5728 value, pass "0" and a hidden argument gives the optional
5730 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5731 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5732 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5734 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5736 vec_safe_push (optionalargs
, boolean_false_node
);
5740 /* Pass a NULL pointer for an absent arg. */
5741 parmse
.expr
= null_pointer_node
;
5742 if (arg
->missing_arg_type
== BT_CHARACTER
)
5743 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5748 else if (arg
->expr
->expr_type
== EXPR_NULL
5749 && fsym
&& !fsym
->attr
.pointer
5750 && (fsym
->ts
.type
!= BT_CLASS
5751 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5753 /* Pass a NULL pointer to denote an absent arg. */
5754 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5755 && (fsym
->ts
.type
!= BT_CLASS
5756 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5757 gfc_init_se (&parmse
, NULL
);
5758 parmse
.expr
= null_pointer_node
;
5759 if (arg
->missing_arg_type
== BT_CHARACTER
)
5760 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5762 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5763 && e
->ts
.type
== BT_DERIVED
)
5765 /* The derived type needs to be converted to a temporary
5767 gfc_init_se (&parmse
, se
);
5768 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5770 && e
->expr_type
== EXPR_VARIABLE
5771 && e
->symtree
->n
.sym
->attr
.optional
,
5772 CLASS_DATA (fsym
)->attr
.class_pointer
5773 || CLASS_DATA (fsym
)->attr
.allocatable
);
5775 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
5777 /* The intrinsic type needs to be converted to a temporary
5778 CLASS object for the unlimited polymorphic formal. */
5779 gfc_find_vtab (&e
->ts
);
5780 gfc_init_se (&parmse
, se
);
5781 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5784 else if (se
->ss
&& se
->ss
->info
->useflags
)
5790 /* An elemental function inside a scalarized loop. */
5791 gfc_init_se (&parmse
, se
);
5792 parm_kind
= ELEMENTAL
;
5794 /* When no fsym is present, ulim_copy is set and this is a third or
5795 fourth argument, use call-by-value instead of by reference to
5796 hand the length properties to the copy routine (i.e., most of the
5797 time this will be a call to a __copy_character_* routine where the
5798 third and fourth arguments are the lengths of a deferred length
5800 if ((fsym
&& fsym
->attr
.value
)
5801 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5802 gfc_conv_expr (&parmse
, e
);
5804 gfc_conv_expr_reference (&parmse
, e
);
5806 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5807 && e
->expr_type
== EXPR_FUNCTION
)
5808 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5811 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5812 && gfc_is_class_container_ref (e
))
5814 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5816 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5817 && e
->symtree
->n
.sym
->attr
.optional
)
5819 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5820 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5821 TREE_TYPE (parmse
.expr
),
5823 fold_convert (TREE_TYPE (parmse
.expr
),
5824 null_pointer_node
));
5828 /* If we are passing an absent array as optional dummy to an
5829 elemental procedure, make sure that we pass NULL when the data
5830 pointer is NULL. We need this extra conditional because of
5831 scalarization which passes arrays elements to the procedure,
5832 ignoring the fact that the array can be absent/unallocated/... */
5833 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5835 tree descriptor_data
;
5837 descriptor_data
= ss
->info
->data
.array
.data
;
5838 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5840 fold_convert (TREE_TYPE (descriptor_data
),
5841 null_pointer_node
));
5843 = fold_build3_loc (input_location
, COND_EXPR
,
5844 TREE_TYPE (parmse
.expr
),
5845 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5846 fold_convert (TREE_TYPE (parmse
.expr
),
5851 /* The scalarizer does not repackage the reference to a class
5852 array - instead it returns a pointer to the data element. */
5853 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5854 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5855 fsym
->attr
.intent
!= INTENT_IN
5856 && (CLASS_DATA (fsym
)->attr
.class_pointer
5857 || CLASS_DATA (fsym
)->attr
.allocatable
),
5859 && e
->expr_type
== EXPR_VARIABLE
5860 && e
->symtree
->n
.sym
->attr
.optional
,
5861 CLASS_DATA (fsym
)->attr
.class_pointer
5862 || CLASS_DATA (fsym
)->attr
.allocatable
);
5869 gfc_init_se (&parmse
, NULL
);
5871 /* Check whether the expression is a scalar or not; we cannot use
5872 e->rank as it can be nonzero for functions arguments. */
5873 argss
= gfc_walk_expr (e
);
5874 scalar
= argss
== gfc_ss_terminator
;
5876 gfc_free_ss_chain (argss
);
5878 /* Special handling for passing scalar polymorphic coarrays;
5879 otherwise one passes "class->_data.data" instead of "&class". */
5880 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5881 && fsym
&& fsym
->ts
.type
== BT_CLASS
5882 && CLASS_DATA (fsym
)->attr
.codimension
5883 && !CLASS_DATA (fsym
)->attr
.dimension
)
5885 gfc_add_class_array_ref (e
);
5886 parmse
.want_coarray
= 1;
5890 /* A scalar or transformational function. */
5893 if (e
->expr_type
== EXPR_VARIABLE
5894 && e
->symtree
->n
.sym
->attr
.cray_pointee
5895 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5897 /* The Cray pointer needs to be converted to a pointer to
5898 a type given by the expression. */
5899 gfc_conv_expr (&parmse
, e
);
5900 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5901 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5902 parmse
.expr
= convert (type
, tmp
);
5905 else if (sym
->attr
.is_bind_c
&& e
5906 && (is_CFI_desc (fsym
, NULL
)
5907 || non_unity_length_string
))
5908 /* Implement F2018, C.12.6.1: paragraph (2). */
5909 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5911 else if (fsym
&& fsym
->attr
.value
)
5913 if (fsym
->ts
.type
== BT_CHARACTER
5914 && fsym
->ts
.is_c_interop
5915 && fsym
->ns
->proc_name
!= NULL
5916 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5919 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5920 if (parmse
.expr
== NULL
)
5921 gfc_conv_expr (&parmse
, e
);
5925 gfc_conv_expr (&parmse
, e
);
5926 if (fsym
->attr
.optional
5927 && fsym
->ts
.type
!= BT_CLASS
5928 && fsym
->ts
.type
!= BT_DERIVED
)
5930 if (e
->expr_type
!= EXPR_VARIABLE
5931 || !e
->symtree
->n
.sym
->attr
.optional
5933 vec_safe_push (optionalargs
, boolean_true_node
);
5936 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5937 if (!e
->symtree
->n
.sym
->attr
.value
)
5939 = fold_build3_loc (input_location
, COND_EXPR
,
5940 TREE_TYPE (parmse
.expr
),
5942 fold_convert (TREE_TYPE (parmse
.expr
),
5943 integer_zero_node
));
5945 vec_safe_push (optionalargs
,
5946 fold_convert (boolean_type_node
,
5953 else if (arg
->name
&& arg
->name
[0] == '%')
5954 /* Argument list functions %VAL, %LOC and %REF are signalled
5955 through arg->name. */
5956 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5957 else if ((e
->expr_type
== EXPR_FUNCTION
)
5958 && ((e
->value
.function
.esym
5959 && e
->value
.function
.esym
->result
->attr
.pointer
)
5960 || (!e
->value
.function
.esym
5961 && e
->symtree
->n
.sym
->attr
.pointer
))
5962 && fsym
&& fsym
->attr
.target
)
5964 gfc_conv_expr (&parmse
, e
);
5965 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5968 else if (e
->expr_type
== EXPR_FUNCTION
5969 && e
->symtree
->n
.sym
->result
5970 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5971 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5973 /* Functions returning procedure pointers. */
5974 gfc_conv_expr (&parmse
, e
);
5975 if (fsym
&& fsym
->attr
.proc_pointer
)
5976 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5981 if (e
->ts
.type
== BT_CLASS
&& fsym
5982 && fsym
->ts
.type
== BT_CLASS
5983 && (!CLASS_DATA (fsym
)->as
5984 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5985 && CLASS_DATA (e
)->attr
.codimension
)
5987 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5988 gcc_assert (!CLASS_DATA (fsym
)->as
);
5989 gfc_add_class_array_ref (e
);
5990 parmse
.want_coarray
= 1;
5991 gfc_conv_expr_reference (&parmse
, e
);
5992 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5994 && e
->expr_type
== EXPR_VARIABLE
);
5996 else if (e
->ts
.type
== BT_CLASS
&& fsym
5997 && fsym
->ts
.type
== BT_CLASS
5998 && !CLASS_DATA (fsym
)->as
5999 && !CLASS_DATA (e
)->as
6000 && strcmp (fsym
->ts
.u
.derived
->name
,
6001 e
->ts
.u
.derived
->name
))
6003 type
= gfc_typenode_for_spec (&fsym
->ts
);
6004 var
= gfc_create_var (type
, fsym
->name
);
6005 gfc_conv_expr (&parmse
, e
);
6006 if (fsym
->attr
.optional
6007 && e
->expr_type
== EXPR_VARIABLE
6008 && e
->symtree
->n
.sym
->attr
.optional
)
6012 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6013 cond
= fold_build2_loc (input_location
, NE_EXPR
,
6014 logical_type_node
, tmp
,
6015 fold_convert (TREE_TYPE (tmp
),
6016 null_pointer_node
));
6017 gfc_start_block (&block
);
6018 gfc_add_modify (&block
, var
,
6019 fold_build1_loc (input_location
,
6021 type
, parmse
.expr
));
6022 gfc_add_expr_to_block (&parmse
.pre
,
6023 fold_build3_loc (input_location
,
6024 COND_EXPR
, void_type_node
,
6025 cond
, gfc_finish_block (&block
),
6026 build_empty_stmt (input_location
)));
6027 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6028 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
6029 TREE_TYPE (parmse
.expr
),
6031 fold_convert (TREE_TYPE (parmse
.expr
),
6032 null_pointer_node
));
6036 /* Since the internal representation of unlimited
6037 polymorphic expressions includes an extra field
6038 that other class objects do not, a cast to the
6039 formal type does not work. */
6040 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
6044 /* Set the _data field. */
6045 tmp
= gfc_class_data_get (var
);
6046 efield
= fold_convert (TREE_TYPE (tmp
),
6047 gfc_class_data_get (parmse
.expr
));
6048 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6050 /* Set the _vptr field. */
6051 tmp
= gfc_class_vptr_get (var
);
6052 efield
= fold_convert (TREE_TYPE (tmp
),
6053 gfc_class_vptr_get (parmse
.expr
));
6054 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6056 /* Set the _len field. */
6057 tmp
= gfc_class_len_get (var
);
6058 gfc_add_modify (&parmse
.pre
, tmp
,
6059 build_int_cst (TREE_TYPE (tmp
), 0));
6063 tmp
= fold_build1_loc (input_location
,
6066 gfc_add_modify (&parmse
.pre
, var
, tmp
);
6069 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6075 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
6076 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
6077 && !e
->symtree
->n
.sym
->attr
.dimension
6078 && !e
->symtree
->n
.sym
->attr
.pointer
6080 && !e
->symtree
->n
.sym
->attr
.dummy
6081 /* FIXME - PR 87395 and PR 41453 */
6082 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
6083 && !e
->symtree
->n
.sym
->attr
.associate_var
6084 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
6085 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
6087 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
6089 /* Catch base objects that are not variables. */
6090 if (e
->ts
.type
== BT_CLASS
6091 && e
->expr_type
!= EXPR_VARIABLE
6092 && expr
&& e
== expr
->base_expr
)
6093 base_object
= build_fold_indirect_ref_loc (input_location
,
6096 /* A class array element needs converting back to be a
6097 class object, if the formal argument is a class object. */
6098 if (fsym
&& fsym
->ts
.type
== BT_CLASS
6099 && e
->ts
.type
== BT_CLASS
6100 && ((CLASS_DATA (fsym
)->as
6101 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
6102 || CLASS_DATA (e
)->attr
.dimension
))
6103 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6104 fsym
->attr
.intent
!= INTENT_IN
6105 && (CLASS_DATA (fsym
)->attr
.class_pointer
6106 || CLASS_DATA (fsym
)->attr
.allocatable
),
6108 && e
->expr_type
== EXPR_VARIABLE
6109 && e
->symtree
->n
.sym
->attr
.optional
,
6110 CLASS_DATA (fsym
)->attr
.class_pointer
6111 || CLASS_DATA (fsym
)->attr
.allocatable
);
6113 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6114 allocated on entry, it must be deallocated. */
6115 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
6116 && (fsym
->attr
.allocatable
6117 || (fsym
->ts
.type
== BT_CLASS
6118 && CLASS_DATA (fsym
)->attr
.allocatable
)))
6123 gfc_init_block (&block
);
6125 if (e
->ts
.type
== BT_CLASS
)
6126 ptr
= gfc_class_data_get (ptr
);
6128 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
6131 gfc_add_expr_to_block (&block
, tmp
);
6132 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6133 void_type_node
, ptr
,
6135 gfc_add_expr_to_block (&block
, tmp
);
6137 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
6139 gfc_add_modify (&block
, ptr
,
6140 fold_convert (TREE_TYPE (ptr
),
6141 null_pointer_node
));
6142 gfc_add_expr_to_block (&block
, tmp
);
6144 else if (fsym
->ts
.type
== BT_CLASS
)
6147 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
6148 tmp
= gfc_get_symbol_decl (vtab
);
6149 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6150 ptr
= gfc_class_vptr_get (parmse
.expr
);
6151 gfc_add_modify (&block
, ptr
,
6152 fold_convert (TREE_TYPE (ptr
), tmp
));
6153 gfc_add_expr_to_block (&block
, tmp
);
6156 if (fsym
->attr
.optional
6157 && e
->expr_type
== EXPR_VARIABLE
6158 && e
->symtree
->n
.sym
->attr
.optional
)
6160 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6162 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6163 gfc_finish_block (&block
),
6164 build_empty_stmt (input_location
));
6167 tmp
= gfc_finish_block (&block
);
6169 gfc_add_expr_to_block (&se
->pre
, tmp
);
6172 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
6173 || fsym
->ts
.type
== BT_ASSUMED
)
6174 && e
->ts
.type
== BT_CLASS
6175 && !CLASS_DATA (e
)->attr
.dimension
6176 && !CLASS_DATA (e
)->attr
.codimension
)
6178 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6179 /* The result is a class temporary, whose _data component
6180 must be freed to avoid a memory leak. */
6181 if (e
->expr_type
== EXPR_FUNCTION
6182 && CLASS_DATA (e
)->attr
.allocatable
)
6188 /* Borrow the function symbol to make a call to
6189 gfc_add_finalizer_call and then restore it. */
6190 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6191 e
->symtree
->n
.sym
->backend_decl
6192 = TREE_OPERAND (parmse
.expr
, 0);
6193 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6194 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6195 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6197 gfc_free_expr (var
);
6198 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6199 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6201 /* Then free the class _data. */
6202 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6203 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6206 tmp
= build3_v (COND_EXPR
, tmp
,
6207 gfc_call_free (parmse
.expr
),
6208 build_empty_stmt (input_location
));
6209 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6210 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6214 /* Wrap scalar variable in a descriptor. We need to convert
6215 the address of a pointer back to the pointer itself before,
6216 we can assign it to the data field. */
6218 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6219 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6222 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6223 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6224 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6226 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6229 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6230 && ((fsym
->attr
.pointer
6231 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6232 || (fsym
->attr
.proc_pointer
6233 && !(e
->expr_type
== EXPR_VARIABLE
6234 && e
->symtree
->n
.sym
->attr
.dummy
))
6235 || (fsym
->attr
.proc_pointer
6236 && e
->expr_type
== EXPR_VARIABLE
6237 && gfc_is_proc_ptr_comp (e
))
6238 || (fsym
->attr
.allocatable
6239 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6241 /* Scalar pointer dummy args require an extra level of
6242 indirection. The null pointer already contains
6243 this level of indirection. */
6244 parm_kind
= SCALAR_POINTER
;
6245 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6249 else if (e
->ts
.type
== BT_CLASS
6250 && fsym
&& fsym
->ts
.type
== BT_CLASS
6251 && (CLASS_DATA (fsym
)->attr
.dimension
6252 || CLASS_DATA (fsym
)->attr
.codimension
))
6254 /* Pass a class array. */
6255 parmse
.use_offset
= 1;
6256 gfc_conv_expr_descriptor (&parmse
, e
);
6258 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6259 allocated on entry, it must be deallocated. */
6260 if (fsym
->attr
.intent
== INTENT_OUT
6261 && CLASS_DATA (fsym
)->attr
.allocatable
)
6266 gfc_init_block (&block
);
6268 ptr
= gfc_class_data_get (ptr
);
6270 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6271 NULL_TREE
, NULL_TREE
,
6273 GFC_CAF_COARRAY_NOCOARRAY
);
6274 gfc_add_expr_to_block (&block
, tmp
);
6275 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6276 void_type_node
, ptr
,
6278 gfc_add_expr_to_block (&block
, tmp
);
6279 gfc_reset_vptr (&block
, e
);
6281 if (fsym
->attr
.optional
6282 && e
->expr_type
== EXPR_VARIABLE
6284 || (e
->ref
->type
== REF_ARRAY
6285 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6286 && e
->symtree
->n
.sym
->attr
.optional
)
6288 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6290 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6291 gfc_finish_block (&block
),
6292 build_empty_stmt (input_location
));
6295 tmp
= gfc_finish_block (&block
);
6297 gfc_add_expr_to_block (&se
->pre
, tmp
);
6300 /* The conversion does not repackage the reference to a class
6301 array - _data descriptor. */
6302 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6303 fsym
->attr
.intent
!= INTENT_IN
6304 && (CLASS_DATA (fsym
)->attr
.class_pointer
6305 || CLASS_DATA (fsym
)->attr
.allocatable
),
6307 && e
->expr_type
== EXPR_VARIABLE
6308 && e
->symtree
->n
.sym
->attr
.optional
,
6309 CLASS_DATA (fsym
)->attr
.class_pointer
6310 || CLASS_DATA (fsym
)->attr
.allocatable
);
6314 /* If the argument is a function call that may not create
6315 a temporary for the result, we have to check that we
6316 can do it, i.e. that there is no alias between this
6317 argument and another one. */
6318 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6324 intent
= fsym
->attr
.intent
;
6326 intent
= INTENT_UNKNOWN
;
6328 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6330 parmse
.force_tmp
= 1;
6332 iarg
= e
->value
.function
.actual
->expr
;
6334 /* Temporary needed if aliasing due to host association. */
6335 if (sym
->attr
.contained
6337 && !sym
->attr
.implicit_pure
6338 && !sym
->attr
.use_assoc
6339 && iarg
->expr_type
== EXPR_VARIABLE
6340 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6341 parmse
.force_tmp
= 1;
6343 /* Ditto within module. */
6344 if (sym
->attr
.use_assoc
6346 && !sym
->attr
.implicit_pure
6347 && iarg
->expr_type
== EXPR_VARIABLE
6348 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6349 parmse
.force_tmp
= 1;
6352 if (sym
->attr
.is_bind_c
&& e
6353 && (is_CFI_desc (fsym
, NULL
) || non_unity_length_string
))
6354 /* Implement F2018, C.12.6.1: paragraph (2). */
6355 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6357 else if (e
->expr_type
== EXPR_VARIABLE
6358 && is_subref_array (e
)
6359 && !(fsym
&& fsym
->attr
.pointer
))
6360 /* The actual argument is a component reference to an
6361 array of derived types. In this case, the argument
6362 is converted to a temporary, which is passed and then
6363 written back after the procedure call. */
6364 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6365 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6366 fsym
&& fsym
->attr
.pointer
);
6368 else if (gfc_is_class_array_ref (e
, NULL
)
6369 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6370 /* The actual argument is a component reference to an
6371 array of derived types. In this case, the argument
6372 is converted to a temporary, which is passed and then
6373 written back after the procedure call.
6374 OOP-TODO: Insert code so that if the dynamic type is
6375 the same as the declared type, copy-in/copy-out does
6377 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6379 fsym
->attr
.pointer
);
6381 else if (gfc_is_class_array_function (e
)
6382 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6383 /* See previous comment. For function actual argument,
6384 the write out is not needed so the intent is set as
6387 e
->must_finalize
= 1;
6388 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6389 INTENT_IN
, fsym
->attr
.pointer
);
6391 else if (fsym
&& fsym
->attr
.contiguous
6392 && !gfc_is_simply_contiguous (e
, false, true)
6393 && gfc_expr_is_variable (e
))
6395 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6397 fsym
->attr
.pointer
);
6400 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6403 /* Unallocated allocatable arrays and unassociated pointer arrays
6404 need their dtype setting if they are argument associated with
6405 assumed rank dummies. */
6406 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6407 && fsym
->as
->type
== AS_ASSUMED_RANK
)
6409 if (gfc_expr_attr (e
).pointer
6410 || gfc_expr_attr (e
).allocatable
)
6411 set_dtype_for_unallocated (&parmse
, e
);
6412 else if (e
->expr_type
== EXPR_VARIABLE
6414 && e
->ref
->u
.ar
.type
== AR_FULL
6415 && e
->symtree
->n
.sym
->attr
.dummy
6416 && e
->symtree
->n
.sym
->as
6417 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
6420 tmp
= build_fold_indirect_ref_loc (input_location
,
6422 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6423 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6424 gfc_rank_cst
[e
->rank
- 1],
6429 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6430 allocated on entry, it must be deallocated. */
6431 if (fsym
&& fsym
->attr
.allocatable
6432 && fsym
->attr
.intent
== INTENT_OUT
)
6434 if (fsym
->ts
.type
== BT_DERIVED
6435 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6437 // deallocate the components first
6438 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6439 parmse
.expr
, e
->rank
);
6440 if (tmp
!= NULL_TREE
)
6441 gfc_add_expr_to_block (&se
->pre
, tmp
);
6445 /* With bind(C), the actual argument is replaced by a bind-C
6446 descriptor; in this case, the data component arrives here,
6447 which shall not be dereferenced, but still freed and
6449 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6450 tmp
= build_fold_indirect_ref_loc (input_location
,
6452 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6453 tmp
= gfc_conv_descriptor_data_get (tmp
);
6454 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6455 NULL_TREE
, NULL_TREE
, true,
6457 GFC_CAF_COARRAY_NOCOARRAY
);
6458 if (fsym
->attr
.optional
6459 && e
->expr_type
== EXPR_VARIABLE
6460 && e
->symtree
->n
.sym
->attr
.optional
)
6461 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6463 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6464 tmp
, build_empty_stmt (input_location
));
6465 gfc_add_expr_to_block (&se
->pre
, tmp
);
6470 /* The case with fsym->attr.optional is that of a user subroutine
6471 with an interface indicating an optional argument. When we call
6472 an intrinsic subroutine, however, fsym is NULL, but we might still
6473 have an optional argument, so we proceed to the substitution
6475 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6477 /* If an optional argument is itself an optional dummy argument,
6478 check its presence and substitute a null if absent. This is
6479 only needed when passing an array to an elemental procedure
6480 as then array elements are accessed - or no NULL pointer is
6481 allowed and a "1" or "0" should be passed if not present.
6482 When passing a non-array-descriptor full array to a
6483 non-array-descriptor dummy, no check is needed. For
6484 array-descriptor actual to array-descriptor dummy, see
6485 PR 41911 for why a check has to be inserted.
6486 fsym == NULL is checked as intrinsics required the descriptor
6487 but do not always set fsym.
6488 Also, it is necessary to pass a NULL pointer to library routines
6489 which usually ignore optional arguments, so they can handle
6490 these themselves. */
6491 if (e
->expr_type
== EXPR_VARIABLE
6492 && e
->symtree
->n
.sym
->attr
.optional
6493 && (((e
->rank
!= 0 && elemental_proc
)
6494 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6498 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6499 || fsym
->as
->type
== AS_ASSUMED_RANK
6500 || fsym
->as
->type
== AS_DEFERRED
)))))
6501 || se
->ignore_optional
))
6502 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6503 e
->representation
.length
);
6508 /* Obtain the character length of an assumed character length
6509 length procedure from the typespec. */
6510 if (fsym
->ts
.type
== BT_CHARACTER
6511 && parmse
.string_length
== NULL_TREE
6512 && e
->ts
.type
== BT_PROCEDURE
6513 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6514 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6515 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6517 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6518 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6522 if (fsym
&& need_interface_mapping
&& e
)
6523 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6525 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6526 gfc_add_block_to_block (&post
, &parmse
.post
);
6528 /* Allocated allocatable components of derived types must be
6529 deallocated for non-variable scalars, array arguments to elemental
6530 procedures, and array arguments with descriptor to non-elemental
6531 procedures. As bounds information for descriptorless arrays is no
6532 longer available here, they are dealt with in trans-array.c
6533 (gfc_conv_array_parameter). */
6534 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
6535 && e
->ts
.u
.derived
->attr
.alloc_comp
6536 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
6537 && !expr_may_alias_variables (e
, elemental_proc
))
6540 /* It is known the e returns a structure type with at least one
6541 allocatable component. When e is a function, ensure that the
6542 function is called once only by using a temporary variable. */
6543 if (!DECL_P (parmse
.expr
))
6544 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
6545 parmse
.expr
, &se
->pre
);
6547 if (fsym
&& fsym
->attr
.value
)
6550 tmp
= build_fold_indirect_ref_loc (input_location
,
6553 parm_rank
= e
->rank
;
6561 case (SCALAR_POINTER
):
6562 tmp
= build_fold_indirect_ref_loc (input_location
,
6567 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
6569 /* The derived type is passed to gfc_deallocate_alloc_comp.
6570 Therefore, class actuals can be handled correctly but derived
6571 types passed to class formals need the _data component. */
6572 tmp
= gfc_class_data_get (tmp
);
6573 if (!CLASS_DATA (fsym
)->attr
.dimension
)
6574 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6577 if (e
->expr_type
== EXPR_OP
6578 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
6579 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
6582 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6583 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
6585 gfc_add_expr_to_block (&se
->post
, local_tmp
);
6588 if (!finalized
&& !e
->must_finalize
)
6590 bool scalar_res_outside_loop
;
6591 scalar_res_outside_loop
= e
->expr_type
== EXPR_FUNCTION
6595 if (scalar_res_outside_loop
)
6597 /* Go through the ss chain to find the argument and use
6598 the stored value. */
6599 gfc_ss
*tmp_ss
= parmse
.loop
->ss
;
6600 for (; tmp_ss
; tmp_ss
= tmp_ss
->next
)
6602 && tmp_ss
->info
->expr
== e
6603 && tmp_ss
->info
->data
.scalar
.value
!= NULL_TREE
)
6605 tmp
= tmp_ss
->info
->data
.scalar
.value
;
6610 if ((e
->ts
.type
== BT_CLASS
6611 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
6612 || e
->ts
.type
== BT_DERIVED
)
6613 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6615 else if (e
->ts
.type
== BT_CLASS
)
6616 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6619 if (scalar_res_outside_loop
)
6620 gfc_add_expr_to_block (&parmse
.loop
->post
, tmp
);
6622 gfc_prepend_expr_to_block (&post
, tmp
);
6626 /* Add argument checking of passing an unallocated/NULL actual to
6627 a nonallocatable/nonpointer dummy. */
6629 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6631 symbol_attribute attr
;
6635 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6636 attr
= gfc_expr_attr (e
);
6638 goto end_pointer_check
;
6640 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6641 allocatable to an optional dummy, cf. 12.5.2.12. */
6642 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6643 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6644 goto end_pointer_check
;
6648 /* If the actual argument is an optional pointer/allocatable and
6649 the formal argument takes an nonpointer optional value,
6650 it is invalid to pass a non-present argument on, even
6651 though there is no technical reason for this in gfortran.
6652 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6653 tree present
, null_ptr
, type
;
6655 if (attr
.allocatable
6656 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6657 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6658 "allocated or not present",
6659 e
->symtree
->n
.sym
->name
);
6660 else if (attr
.pointer
6661 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6662 msg
= xasprintf ("Pointer actual argument '%s' is not "
6663 "associated or not present",
6664 e
->symtree
->n
.sym
->name
);
6665 else if (attr
.proc_pointer
6666 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6667 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6668 "associated or not present",
6669 e
->symtree
->n
.sym
->name
);
6671 goto end_pointer_check
;
6673 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6674 type
= TREE_TYPE (present
);
6675 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6676 logical_type_node
, present
,
6678 null_pointer_node
));
6679 type
= TREE_TYPE (parmse
.expr
);
6680 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6681 logical_type_node
, parmse
.expr
,
6683 null_pointer_node
));
6684 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6685 logical_type_node
, present
, null_ptr
);
6689 if (attr
.allocatable
6690 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6691 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6692 "allocated", e
->symtree
->n
.sym
->name
);
6693 else if (attr
.pointer
6694 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6695 msg
= xasprintf ("Pointer actual argument '%s' is not "
6696 "associated", e
->symtree
->n
.sym
->name
);
6697 else if (attr
.proc_pointer
6698 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6699 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6700 "associated", e
->symtree
->n
.sym
->name
);
6702 goto end_pointer_check
;
6706 /* If the argument is passed by value, we need to strip the
6708 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6709 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6711 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6712 logical_type_node
, tmp
,
6713 fold_convert (TREE_TYPE (tmp
),
6714 null_pointer_node
));
6717 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6723 /* Deferred length dummies pass the character length by reference
6724 so that the value can be returned. */
6725 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6727 if (INDIRECT_REF_P (parmse
.string_length
))
6728 /* In chains of functions/procedure calls the string_length already
6729 is a pointer to the variable holding the length. Therefore
6730 remove the deref on call. */
6731 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6734 tmp
= parmse
.string_length
;
6735 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6736 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6737 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6741 /* Character strings are passed as two parameters, a length and a
6742 pointer - except for Bind(c) which only passes the pointer.
6743 An unlimited polymorphic formal argument likewise does not
6745 if (parmse
.string_length
!= NULL_TREE
6746 && !sym
->attr
.is_bind_c
6747 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6748 vec_safe_push (stringargs
, parmse
.string_length
);
6750 /* When calling __copy for character expressions to unlimited
6751 polymorphic entities, the dst argument needs a string length. */
6752 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6753 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6754 && arg
->next
&& arg
->next
->expr
6755 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6756 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6757 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6758 vec_safe_push (stringargs
, parmse
.string_length
);
6760 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6761 pass the token and the offset as additional arguments. */
6762 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6763 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6764 && !fsym
->attr
.allocatable
)
6765 || (fsym
->ts
.type
== BT_CLASS
6766 && CLASS_DATA (fsym
)->attr
.codimension
6767 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6769 /* Token and offset. */
6770 vec_safe_push (stringargs
, null_pointer_node
);
6771 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6772 gcc_assert (fsym
->attr
.optional
);
6774 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6775 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6776 && !fsym
->attr
.allocatable
)
6777 || (fsym
->ts
.type
== BT_CLASS
6778 && CLASS_DATA (fsym
)->attr
.codimension
6779 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6781 tree caf_decl
, caf_type
;
6784 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6785 caf_type
= TREE_TYPE (caf_decl
);
6787 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6788 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6789 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6790 tmp
= gfc_conv_descriptor_token (caf_decl
);
6791 else if (DECL_LANG_SPECIFIC (caf_decl
)
6792 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6793 tmp
= GFC_DECL_TOKEN (caf_decl
);
6796 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6797 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6798 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6801 vec_safe_push (stringargs
, tmp
);
6803 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6804 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6805 offset
= build_int_cst (gfc_array_index_type
, 0);
6806 else if (DECL_LANG_SPECIFIC (caf_decl
)
6807 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6808 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6809 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6810 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6812 offset
= build_int_cst (gfc_array_index_type
, 0);
6814 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6815 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6818 gcc_assert (POINTER_TYPE_P (caf_type
));
6822 tmp2
= fsym
->ts
.type
== BT_CLASS
6823 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6824 if ((fsym
->ts
.type
!= BT_CLASS
6825 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6826 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6827 || (fsym
->ts
.type
== BT_CLASS
6828 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6829 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6831 if (fsym
->ts
.type
== BT_CLASS
)
6832 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6835 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6836 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6838 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6839 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6841 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6842 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6845 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6848 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6849 gfc_array_index_type
,
6850 fold_convert (gfc_array_index_type
, tmp2
),
6851 fold_convert (gfc_array_index_type
, tmp
));
6852 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6853 gfc_array_index_type
, offset
, tmp
);
6855 vec_safe_push (stringargs
, offset
);
6858 vec_safe_push (arglist
, parmse
.expr
);
6860 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6864 else if (sym
->ts
.type
== BT_CLASS
)
6865 ts
= CLASS_DATA (sym
)->ts
;
6869 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6870 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6871 else if (ts
.type
== BT_CHARACTER
)
6873 if (ts
.u
.cl
->length
== NULL
)
6875 /* Assumed character length results are not allowed by C418 of the 2003
6876 standard and are trapped in resolve.c; except in the case of SPREAD
6877 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6878 we take the character length of the first argument for the result.
6879 For dummies, we have to look through the formal argument list for
6880 this function and use the character length found there.*/
6882 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6883 else if (!sym
->attr
.dummy
)
6884 cl
.backend_decl
= (*stringargs
)[0];
6887 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6888 for (; formal
; formal
= formal
->next
)
6889 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6890 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6892 len
= cl
.backend_decl
;
6898 /* Calculate the length of the returned string. */
6899 gfc_init_se (&parmse
, NULL
);
6900 if (need_interface_mapping
)
6901 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6903 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6904 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6905 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6907 /* TODO: It would be better to have the charlens as
6908 gfc_charlen_type_node already when the interface is
6909 created instead of converting it here (see PR 84615). */
6910 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6911 gfc_charlen_type_node
,
6912 fold_convert (gfc_charlen_type_node
, tmp
),
6913 build_zero_cst (gfc_charlen_type_node
));
6914 cl
.backend_decl
= tmp
;
6917 /* Set up a charlen structure for it. */
6922 len
= cl
.backend_decl
;
6925 byref
= (comp
&& (comp
->attr
.dimension
6926 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6927 || (!comp
&& gfc_return_by_reference (sym
));
6930 if (se
->direct_byref
)
6932 /* Sometimes, too much indirection can be applied; e.g. for
6933 function_result = array_valued_recursive_function. */
6934 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6935 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6936 && GFC_DESCRIPTOR_TYPE_P
6937 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6938 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6941 /* If the lhs of an assignment x = f(..) is allocatable and
6942 f2003 is allowed, we must do the automatic reallocation.
6943 TODO - deal with intrinsics, without using a temporary. */
6944 if (flag_realloc_lhs
6945 && se
->ss
&& se
->ss
->loop_chain
6946 && se
->ss
->loop_chain
->is_alloc_lhs
6947 && !expr
->value
.function
.isym
6948 && sym
->result
->as
!= NULL
)
6950 /* Evaluate the bounds of the result, if known. */
6951 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6954 /* Perform the automatic reallocation. */
6955 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6957 gfc_add_expr_to_block (&se
->pre
, tmp
);
6959 /* Pass the temporary as the first argument. */
6960 result
= info
->descriptor
;
6963 result
= build_fold_indirect_ref_loc (input_location
,
6965 vec_safe_push (retargs
, se
->expr
);
6967 else if (comp
&& comp
->attr
.dimension
)
6969 gcc_assert (se
->loop
&& info
);
6971 /* Set the type of the array. */
6972 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6973 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6975 /* Evaluate the bounds of the result, if known. */
6976 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6978 /* If the lhs of an assignment x = f(..) is allocatable and
6979 f2003 is allowed, we must not generate the function call
6980 here but should just send back the results of the mapping.
6981 This is signalled by the function ss being flagged. */
6982 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6984 gfc_free_interface_mapping (&mapping
);
6985 return has_alternate_specifier
;
6988 /* Create a temporary to store the result. In case the function
6989 returns a pointer, the temporary will be a shallow copy and
6990 mustn't be deallocated. */
6991 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6992 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6993 tmp
, NULL_TREE
, false,
6994 !comp
->attr
.pointer
, callee_alloc
,
6995 &se
->ss
->info
->expr
->where
);
6997 /* Pass the temporary as the first argument. */
6998 result
= info
->descriptor
;
6999 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7000 vec_safe_push (retargs
, tmp
);
7002 else if (!comp
&& sym
->result
->attr
.dimension
)
7004 gcc_assert (se
->loop
&& info
);
7006 /* Set the type of the array. */
7007 tmp
= gfc_typenode_for_spec (&ts
);
7008 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
7010 /* Evaluate the bounds of the result, if known. */
7011 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
7013 /* If the lhs of an assignment x = f(..) is allocatable and
7014 f2003 is allowed, we must not generate the function call
7015 here but should just send back the results of the mapping.
7016 This is signalled by the function ss being flagged. */
7017 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
7019 gfc_free_interface_mapping (&mapping
);
7020 return has_alternate_specifier
;
7023 /* Create a temporary to store the result. In case the function
7024 returns a pointer, the temporary will be a shallow copy and
7025 mustn't be deallocated. */
7026 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
7027 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
7028 tmp
, NULL_TREE
, false,
7029 !sym
->attr
.pointer
, callee_alloc
,
7030 &se
->ss
->info
->expr
->where
);
7032 /* Pass the temporary as the first argument. */
7033 result
= info
->descriptor
;
7034 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7035 vec_safe_push (retargs
, tmp
);
7037 else if (ts
.type
== BT_CHARACTER
)
7039 /* Pass the string length. */
7040 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
7041 type
= build_pointer_type (type
);
7043 /* Emit a DECL_EXPR for the VLA type. */
7044 tmp
= TREE_TYPE (type
);
7046 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
7048 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
7049 DECL_ARTIFICIAL (tmp
) = 1;
7050 DECL_IGNORED_P (tmp
) = 1;
7051 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
7052 TREE_TYPE (tmp
), tmp
);
7053 gfc_add_expr_to_block (&se
->pre
, tmp
);
7056 /* Return an address to a char[0:len-1]* temporary for
7057 character pointers. */
7058 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7059 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7061 var
= gfc_create_var (type
, "pstr");
7063 if ((!comp
&& sym
->attr
.allocatable
)
7064 || (comp
&& comp
->attr
.allocatable
))
7066 gfc_add_modify (&se
->pre
, var
,
7067 fold_convert (TREE_TYPE (var
),
7068 null_pointer_node
));
7069 tmp
= gfc_call_free (var
);
7070 gfc_add_expr_to_block (&se
->post
, tmp
);
7073 /* Provide an address expression for the function arguments. */
7074 var
= gfc_build_addr_expr (NULL_TREE
, var
);
7077 var
= gfc_conv_string_tmp (se
, type
, len
);
7079 vec_safe_push (retargs
, var
);
7083 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
7085 type
= gfc_get_complex_type (ts
.kind
);
7086 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
7087 vec_safe_push (retargs
, var
);
7090 /* Add the string length to the argument list. */
7091 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
7095 tmp
= gfc_evaluate_now (len
, &se
->pre
);
7096 TREE_STATIC (tmp
) = 1;
7097 gfc_add_modify (&se
->pre
, tmp
,
7098 build_int_cst (TREE_TYPE (tmp
), 0));
7099 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7100 vec_safe_push (retargs
, tmp
);
7102 else if (ts
.type
== BT_CHARACTER
)
7103 vec_safe_push (retargs
, len
);
7105 gfc_free_interface_mapping (&mapping
);
7107 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7108 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
7109 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
7110 vec_safe_reserve (retargs
, arglen
);
7112 /* Add the return arguments. */
7113 vec_safe_splice (retargs
, arglist
);
7115 /* Add the hidden present status for optional+value to the arguments. */
7116 vec_safe_splice (retargs
, optionalargs
);
7118 /* Add the hidden string length parameters to the arguments. */
7119 vec_safe_splice (retargs
, stringargs
);
7121 /* We may want to append extra arguments here. This is used e.g. for
7122 calls to libgfortran_matmul_??, which need extra information. */
7123 vec_safe_splice (retargs
, append_args
);
7127 /* Generate the actual call. */
7128 if (base_object
== NULL_TREE
)
7129 conv_function_val (se
, sym
, expr
, args
);
7131 conv_base_obj_fcn_val (se
, base_object
, expr
);
7133 /* If there are alternate return labels, function type should be
7134 integer. Can't modify the type in place though, since it can be shared
7135 with other functions. For dummy arguments, the typing is done to
7136 this result, even if it has to be repeated for each call. */
7137 if (has_alternate_specifier
7138 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
7140 if (!sym
->attr
.dummy
)
7142 TREE_TYPE (sym
->backend_decl
)
7143 = build_function_type (integer_type_node
,
7144 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
7145 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
7148 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
7151 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
7152 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
7154 /* Allocatable scalar function results must be freed and nullified
7155 after use. This necessitates the creation of a temporary to
7156 hold the result to prevent duplicate calls. */
7157 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
7158 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
7159 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
7161 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7162 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
7164 tmp
= gfc_call_free (tmp
);
7165 gfc_add_expr_to_block (&post
, tmp
);
7166 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
7169 /* If we have a pointer function, but we don't want a pointer, e.g.
7172 where f is pointer valued, we have to dereference the result. */
7173 if (!se
->want_pointer
&& !byref
7174 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7175 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
7176 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7178 /* f2c calling conventions require a scalar default real function to
7179 return a double precision result. Convert this back to default
7180 real. We only care about the cases that can happen in Fortran 77.
7182 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
7183 && sym
->ts
.kind
== gfc_default_real_kind
7184 && !sym
->attr
.always_explicit
)
7185 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
7187 /* A pure function may still have side-effects - it may modify its
7189 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7191 if (!sym
->attr
.pure
)
7192 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7197 /* Add the function call to the pre chain. There is no expression. */
7198 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
7199 se
->expr
= NULL_TREE
;
7201 if (!se
->direct_byref
)
7203 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
7205 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
7207 /* Check the data pointer hasn't been modified. This would
7208 happen in a function returning a pointer. */
7209 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7210 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7213 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7216 se
->expr
= info
->descriptor
;
7217 /* Bundle in the string length. */
7218 se
->string_length
= len
;
7220 else if (ts
.type
== BT_CHARACTER
)
7222 /* Dereference for character pointer results. */
7223 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7224 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7225 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7229 se
->string_length
= len
;
7233 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7234 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7239 /* Associate the rhs class object's meta-data with the result, when the
7240 result is a temporary. */
7241 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7242 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7243 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7246 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7248 gfc_init_se (&parmse
, NULL
);
7249 parmse
.data_not_needed
= 1;
7250 gfc_conv_expr (&parmse
, class_expr
);
7251 if (!DECL_LANG_SPECIFIC (result
))
7252 gfc_allocate_lang_decl (result
);
7253 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7254 gfc_free_expr (class_expr
);
7255 /* -fcheck= can add diagnostic code, which has to be placed before
7257 if (parmse
.pre
.head
!= NULL
)
7258 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7259 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7262 /* Follow the function call with the argument post block. */
7265 gfc_add_block_to_block (&se
->pre
, &post
);
7267 /* Transformational functions of derived types with allocatable
7268 components must have the result allocatable components copied when the
7269 argument is actually given. */
7270 arg
= expr
->value
.function
.actual
;
7271 if (result
&& arg
&& expr
->rank
7272 && expr
->value
.function
.isym
7273 && expr
->value
.function
.isym
->transformational
7275 && arg
->expr
->ts
.type
== BT_DERIVED
7276 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7279 /* Copy the allocatable components. We have to use a
7280 temporary here to prevent source allocatable components
7281 from being corrupted. */
7282 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7283 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7284 result
, tmp2
, expr
->rank
, 0);
7285 gfc_add_expr_to_block (&se
->pre
, tmp
);
7286 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7288 gfc_add_expr_to_block (&se
->pre
, tmp
);
7290 /* Finally free the temporary's data field. */
7291 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7292 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7293 NULL_TREE
, NULL_TREE
, true,
7294 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7295 gfc_add_expr_to_block (&se
->pre
, tmp
);
7300 /* For a function with a class array result, save the result as
7301 a temporary, set the info fields needed by the scalarizer and
7302 call the finalization function of the temporary. Note that the
7303 nullification of allocatable components needed by the result
7304 is done in gfc_trans_assignment_1. */
7305 if (expr
&& ((gfc_is_class_array_function (expr
)
7306 && se
->ss
&& se
->ss
->loop
)
7307 || gfc_is_alloc_class_scalar_function (expr
))
7308 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7309 && expr
->must_finalize
)
7314 if (se
->ss
&& se
->ss
->loop
)
7316 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7317 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7318 tmp
= gfc_class_data_get (se
->expr
);
7319 info
->descriptor
= tmp
;
7320 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7321 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7322 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7324 tree dim
= gfc_rank_cst
[n
];
7325 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7326 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7331 /* TODO Eliminate the doubling of temporaries. This
7332 one is necessary to ensure no memory leakage. */
7333 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7334 tmp
= gfc_class_data_get (se
->expr
);
7335 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7336 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7339 if ((gfc_is_class_array_function (expr
)
7340 || gfc_is_alloc_class_scalar_function (expr
))
7341 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7342 goto no_finalization
;
7344 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7345 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7348 fold_convert (TREE_TYPE (final_fndecl
),
7349 null_pointer_node
));
7350 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7352 tmp
= build_call_expr_loc (input_location
,
7354 gfc_build_addr_expr (NULL
, tmp
),
7355 gfc_class_vtab_size_get (se
->expr
),
7356 boolean_false_node
);
7357 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7358 void_type_node
, is_final
, tmp
,
7359 build_empty_stmt (input_location
));
7361 if (se
->ss
&& se
->ss
->loop
)
7363 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7364 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7367 fold_convert (TREE_TYPE (info
->data
),
7368 null_pointer_node
));
7369 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7370 void_type_node
, tmp
,
7371 gfc_call_free (info
->data
),
7372 build_empty_stmt (input_location
));
7373 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7378 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7379 classdata
= gfc_class_data_get (se
->expr
);
7380 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7383 fold_convert (TREE_TYPE (classdata
),
7384 null_pointer_node
));
7385 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7386 void_type_node
, tmp
,
7387 gfc_call_free (classdata
),
7388 build_empty_stmt (input_location
));
7389 gfc_add_expr_to_block (&se
->post
, tmp
);
7394 gfc_add_block_to_block (&se
->post
, &post
);
7397 return has_alternate_specifier
;
7401 /* Fill a character string with spaces. */
7404 fill_with_spaces (tree start
, tree type
, tree size
)
7406 stmtblock_t block
, loop
;
7407 tree i
, el
, exit_label
, cond
, tmp
;
7409 /* For a simple char type, we can call memset(). */
7410 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7411 return build_call_expr_loc (input_location
,
7412 builtin_decl_explicit (BUILT_IN_MEMSET
),
7414 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7415 lang_hooks
.to_target_charset (' ')),
7416 fold_convert (size_type_node
, size
));
7418 /* Otherwise, we use a loop:
7419 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7423 /* Initialize variables. */
7424 gfc_init_block (&block
);
7425 i
= gfc_create_var (sizetype
, "i");
7426 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7427 el
= gfc_create_var (build_pointer_type (type
), "el");
7428 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7429 exit_label
= gfc_build_label_decl (NULL_TREE
);
7430 TREE_USED (exit_label
) = 1;
7434 gfc_init_block (&loop
);
7436 /* Exit condition. */
7437 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7438 build_zero_cst (sizetype
));
7439 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7440 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7441 build_empty_stmt (input_location
));
7442 gfc_add_expr_to_block (&loop
, tmp
);
7445 gfc_add_modify (&loop
,
7446 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7447 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7449 /* Increment loop variables. */
7450 gfc_add_modify (&loop
, i
,
7451 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7452 TYPE_SIZE_UNIT (type
)));
7453 gfc_add_modify (&loop
, el
,
7454 fold_build_pointer_plus_loc (input_location
,
7455 el
, TYPE_SIZE_UNIT (type
)));
7457 /* Making the loop... actually loop! */
7458 tmp
= gfc_finish_block (&loop
);
7459 tmp
= build1_v (LOOP_EXPR
, tmp
);
7460 gfc_add_expr_to_block (&block
, tmp
);
7462 /* The exit label. */
7463 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7464 gfc_add_expr_to_block (&block
, tmp
);
7467 return gfc_finish_block (&block
);
7471 /* Generate code to copy a string. */
7474 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7475 int dkind
, tree slength
, tree src
, int skind
)
7477 tree tmp
, dlen
, slen
;
7486 stmtblock_t tempblock
;
7488 gcc_assert (dkind
== skind
);
7490 if (slength
!= NULL_TREE
)
7492 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7493 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
7497 slen
= build_one_cst (gfc_charlen_type_node
);
7501 if (dlength
!= NULL_TREE
)
7503 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
7504 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
7508 dlen
= build_one_cst (gfc_charlen_type_node
);
7512 /* Assign directly if the types are compatible. */
7513 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
7514 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
7516 gfc_add_modify (block
, dsc
, ssc
);
7520 /* The string copy algorithm below generates code like
7524 if (srclen < destlen)
7526 memmove (dest, src, srclen);
7528 memset (&dest[srclen], ' ', destlen - srclen);
7532 // Truncate if too long.
7533 memmove (dest, src, destlen);
7538 /* Do nothing if the destination length is zero. */
7539 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
7540 build_zero_cst (TREE_TYPE (dlen
)));
7542 /* For non-default character kinds, we have to multiply the string
7543 length by the base type size. */
7544 chartype
= gfc_get_char_type (dkind
);
7545 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
7547 fold_convert (TREE_TYPE (slen
),
7548 TYPE_SIZE_UNIT (chartype
)));
7549 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
7551 fold_convert (TREE_TYPE (dlen
),
7552 TYPE_SIZE_UNIT (chartype
)));
7554 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
7555 dest
= fold_convert (pvoid_type_node
, dest
);
7557 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
7559 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
7560 src
= fold_convert (pvoid_type_node
, src
);
7562 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7564 /* Truncate string if source is too long. */
7565 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
7568 /* Copy and pad with spaces. */
7569 tmp3
= build_call_expr_loc (input_location
,
7570 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7572 fold_convert (size_type_node
, slen
));
7574 /* Wstringop-overflow appears at -O3 even though this warning is not
7575 explicitly available in fortran nor can it be switched off. If the
7576 source length is a constant, its negative appears as a very large
7577 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7578 the result of the MINUS_EXPR suppresses this spurious warning. */
7579 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7580 TREE_TYPE(dlen
), dlen
, slen
);
7581 if (slength
&& TREE_CONSTANT (slength
))
7582 tmp
= gfc_evaluate_now (tmp
, block
);
7584 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
7585 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
7587 gfc_init_block (&tempblock
);
7588 gfc_add_expr_to_block (&tempblock
, tmp3
);
7589 gfc_add_expr_to_block (&tempblock
, tmp4
);
7590 tmp3
= gfc_finish_block (&tempblock
);
7592 /* The truncated memmove if the slen >= dlen. */
7593 tmp2
= build_call_expr_loc (input_location
,
7594 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7596 fold_convert (size_type_node
, dlen
));
7598 /* The whole copy_string function is there. */
7599 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
7601 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7602 build_empty_stmt (input_location
));
7603 gfc_add_expr_to_block (block
, tmp
);
7607 /* Translate a statement function.
7608 The value of a statement function reference is obtained by evaluating the
7609 expression using the values of the actual arguments for the values of the
7610 corresponding dummy arguments. */
7613 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
7617 gfc_formal_arglist
*fargs
;
7618 gfc_actual_arglist
*args
;
7621 gfc_saved_var
*saved_vars
;
7627 sym
= expr
->symtree
->n
.sym
;
7628 args
= expr
->value
.function
.actual
;
7629 gfc_init_se (&lse
, NULL
);
7630 gfc_init_se (&rse
, NULL
);
7633 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7635 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7636 temp_vars
= XCNEWVEC (tree
, n
);
7638 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7639 fargs
= fargs
->next
, n
++)
7641 /* Each dummy shall be specified, explicitly or implicitly, to be
7643 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7646 if (fsym
->ts
.type
== BT_CHARACTER
)
7648 /* Copy string arguments. */
7651 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7652 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7654 /* Create a temporary to hold the value. */
7655 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7656 fsym
->ts
.u
.cl
->backend_decl
7657 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7659 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7660 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7662 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7664 gfc_conv_expr (&rse
, args
->expr
);
7665 gfc_conv_string_parameter (&rse
);
7666 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7667 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7669 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7670 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7671 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7672 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7676 /* For everything else, just evaluate the expression. */
7678 /* Create a temporary to hold the value. */
7679 type
= gfc_typenode_for_spec (&fsym
->ts
);
7680 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7682 gfc_conv_expr (&lse
, args
->expr
);
7684 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7685 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7686 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7692 /* Use the temporary variables in place of the real ones. */
7693 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7694 fargs
= fargs
->next
, n
++)
7695 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7697 gfc_conv_expr (se
, sym
->value
);
7699 if (sym
->ts
.type
== BT_CHARACTER
)
7701 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7703 /* Force the expression to the correct length. */
7704 if (!INTEGER_CST_P (se
->string_length
)
7705 || tree_int_cst_lt (se
->string_length
,
7706 sym
->ts
.u
.cl
->backend_decl
))
7708 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7709 tmp
= gfc_create_var (type
, sym
->name
);
7710 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7711 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7712 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7716 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7719 /* Restore the original variables. */
7720 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7721 fargs
= fargs
->next
, n
++)
7722 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7728 /* Translate a function expression. */
7731 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7735 if (expr
->value
.function
.isym
)
7737 gfc_conv_intrinsic_function (se
, expr
);
7741 /* expr.value.function.esym is the resolved (specific) function symbol for
7742 most functions. However this isn't set for dummy procedures. */
7743 sym
= expr
->value
.function
.esym
;
7745 sym
= expr
->symtree
->n
.sym
;
7747 /* The IEEE_ARITHMETIC functions are caught here. */
7748 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7749 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7752 /* We distinguish statement functions from general functions to improve
7753 runtime performance. */
7754 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7756 gfc_conv_statement_function (se
, expr
);
7760 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7765 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7768 is_zero_initializer_p (gfc_expr
* expr
)
7770 if (expr
->expr_type
!= EXPR_CONSTANT
)
7773 /* We ignore constants with prescribed memory representations for now. */
7774 if (expr
->representation
.string
)
7777 switch (expr
->ts
.type
)
7780 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7783 return mpfr_zero_p (expr
->value
.real
)
7784 && MPFR_SIGN (expr
->value
.real
) >= 0;
7787 return expr
->value
.logical
== 0;
7790 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7791 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7792 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7793 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7803 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7808 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7809 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7811 gfc_conv_tmp_array_ref (se
);
7815 /* Build a static initializer. EXPR is the expression for the initial value.
7816 The other parameters describe the variable of the component being
7817 initialized. EXPR may be null. */
7820 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7821 bool array
, bool pointer
, bool procptr
)
7825 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7826 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7827 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7828 return build_constructor (type
, NULL
);
7830 if (!(expr
|| pointer
|| procptr
))
7833 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7834 (these are the only two iso_c_binding derived types that can be
7835 used as initialization expressions). If so, we need to modify
7836 the 'expr' to be that for a (void *). */
7837 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7838 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7840 if (TREE_CODE (type
) == ARRAY_TYPE
)
7841 return build_constructor (type
, NULL
);
7842 else if (POINTER_TYPE_P (type
))
7843 return build_int_cst (type
, 0);
7848 if (array
&& !procptr
)
7851 /* Arrays need special handling. */
7853 ctor
= gfc_build_null_descriptor (type
);
7854 /* Special case assigning an array to zero. */
7855 else if (is_zero_initializer_p (expr
))
7856 ctor
= build_constructor (type
, NULL
);
7858 ctor
= gfc_conv_array_initializer (type
, expr
);
7859 TREE_STATIC (ctor
) = 1;
7862 else if (pointer
|| procptr
)
7864 if (ts
->type
== BT_CLASS
&& !procptr
)
7866 gfc_init_se (&se
, NULL
);
7867 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7868 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7869 TREE_STATIC (se
.expr
) = 1;
7872 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7873 return fold_convert (type
, null_pointer_node
);
7876 gfc_init_se (&se
, NULL
);
7877 se
.want_pointer
= 1;
7878 gfc_conv_expr (&se
, expr
);
7879 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7889 gfc_init_se (&se
, NULL
);
7890 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7891 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7893 gfc_conv_structure (&se
, expr
, 1);
7894 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7895 TREE_STATIC (se
.expr
) = 1;
7899 if (expr
->expr_type
== EXPR_CONSTANT
)
7901 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
, expr
);
7902 TREE_STATIC (ctor
) = 1;
7908 gfc_init_se (&se
, NULL
);
7909 gfc_conv_constant (&se
, expr
);
7910 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7917 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7923 gfc_array_info
*lss_array
;
7930 gfc_start_block (&block
);
7932 /* Initialize the scalarizer. */
7933 gfc_init_loopinfo (&loop
);
7935 gfc_init_se (&lse
, NULL
);
7936 gfc_init_se (&rse
, NULL
);
7939 rss
= gfc_walk_expr (expr
);
7940 if (rss
== gfc_ss_terminator
)
7941 /* The rhs is scalar. Add a ss for the expression. */
7942 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7944 /* Create a SS for the destination. */
7945 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7947 lss_array
= &lss
->info
->data
.array
;
7948 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7949 lss_array
->descriptor
= dest
;
7950 lss_array
->data
= gfc_conv_array_data (dest
);
7951 lss_array
->offset
= gfc_conv_array_offset (dest
);
7952 for (n
= 0; n
< cm
->as
->rank
; n
++)
7954 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7955 lss_array
->stride
[n
] = gfc_index_one_node
;
7957 mpz_init (lss_array
->shape
[n
]);
7958 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7959 cm
->as
->lower
[n
]->value
.integer
);
7960 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7963 /* Associate the SS with the loop. */
7964 gfc_add_ss_to_loop (&loop
, lss
);
7965 gfc_add_ss_to_loop (&loop
, rss
);
7967 /* Calculate the bounds of the scalarization. */
7968 gfc_conv_ss_startstride (&loop
);
7970 /* Setup the scalarizing loops. */
7971 gfc_conv_loop_setup (&loop
, &expr
->where
);
7973 /* Setup the gfc_se structures. */
7974 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7975 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7978 gfc_mark_ss_chain_used (rss
, 1);
7980 gfc_mark_ss_chain_used (lss
, 1);
7982 /* Start the scalarized loop body. */
7983 gfc_start_scalarized_body (&loop
, &body
);
7985 gfc_conv_tmp_array_ref (&lse
);
7986 if (cm
->ts
.type
== BT_CHARACTER
)
7987 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7989 gfc_conv_expr (&rse
, expr
);
7991 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7992 gfc_add_expr_to_block (&body
, tmp
);
7994 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7996 /* Generate the copying loops. */
7997 gfc_trans_scalarizing_loops (&loop
, &body
);
7999 /* Wrap the whole thing up. */
8000 gfc_add_block_to_block (&block
, &loop
.pre
);
8001 gfc_add_block_to_block (&block
, &loop
.post
);
8003 gcc_assert (lss_array
->shape
!= NULL
);
8004 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
8005 gfc_cleanup_loop (&loop
);
8007 return gfc_finish_block (&block
);
8012 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
8022 gfc_expr
*arg
= NULL
;
8024 gfc_start_block (&block
);
8025 gfc_init_se (&se
, NULL
);
8027 /* Get the descriptor for the expressions. */
8028 se
.want_pointer
= 0;
8029 gfc_conv_expr_descriptor (&se
, expr
);
8030 gfc_add_block_to_block (&block
, &se
.pre
);
8031 gfc_add_modify (&block
, dest
, se
.expr
);
8033 /* Deal with arrays of derived types with allocatable components. */
8034 if (gfc_bt_struct (cm
->ts
.type
)
8035 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
8036 // TODO: Fix caf_mode
8037 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
8040 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
8041 && CLASS_DATA(cm
)->attr
.allocatable
)
8043 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
8044 // TODO: Fix caf_mode
8045 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
8050 tmp
= TREE_TYPE (dest
);
8051 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8052 tmp
, expr
->rank
, NULL_TREE
);
8056 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8057 TREE_TYPE(cm
->backend_decl
),
8058 cm
->as
->rank
, NULL_TREE
);
8060 gfc_add_expr_to_block (&block
, tmp
);
8061 gfc_add_block_to_block (&block
, &se
.post
);
8063 if (expr
->expr_type
!= EXPR_VARIABLE
)
8064 gfc_conv_descriptor_data_set (&block
, se
.expr
,
8067 /* We need to know if the argument of a conversion function is a
8068 variable, so that the correct lower bound can be used. */
8069 if (expr
->expr_type
== EXPR_FUNCTION
8070 && expr
->value
.function
.isym
8071 && expr
->value
.function
.isym
->conversion
8072 && expr
->value
.function
.actual
->expr
8073 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
8074 arg
= expr
->value
.function
.actual
->expr
;
8076 /* Obtain the array spec of full array references. */
8078 as
= gfc_get_full_arrayspec_from_expr (arg
);
8080 as
= gfc_get_full_arrayspec_from_expr (expr
);
8082 /* Shift the lbound and ubound of temporaries to being unity,
8083 rather than zero, based. Always calculate the offset. */
8084 offset
= gfc_conv_descriptor_offset_get (dest
);
8085 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8086 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
8088 for (n
= 0; n
< expr
->rank
; n
++)
8093 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8094 TODO It looks as if gfc_conv_expr_descriptor should return
8095 the correct bounds and that the following should not be
8096 necessary. This would simplify gfc_conv_intrinsic_bound
8098 if (as
&& as
->lower
[n
])
8101 gfc_init_se (&lbse
, NULL
);
8102 gfc_conv_expr (&lbse
, as
->lower
[n
]);
8103 gfc_add_block_to_block (&block
, &lbse
.pre
);
8104 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
8108 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
8109 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
8113 lbound
= gfc_conv_descriptor_lbound_get (dest
,
8116 lbound
= gfc_index_one_node
;
8118 lbound
= fold_convert (gfc_array_index_type
, lbound
);
8120 /* Shift the bounds and set the offset accordingly. */
8121 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
8122 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8123 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
8124 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8126 gfc_conv_descriptor_ubound_set (&block
, dest
,
8127 gfc_rank_cst
[n
], tmp
);
8128 gfc_conv_descriptor_lbound_set (&block
, dest
,
8129 gfc_rank_cst
[n
], lbound
);
8131 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8132 gfc_conv_descriptor_lbound_get (dest
,
8134 gfc_conv_descriptor_stride_get (dest
,
8136 gfc_add_modify (&block
, tmp2
, tmp
);
8137 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8139 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
8144 /* If a conversion expression has a null data pointer
8145 argument, nullify the allocatable component. */
8149 if (arg
->symtree
->n
.sym
->attr
.allocatable
8150 || arg
->symtree
->n
.sym
->attr
.pointer
)
8152 non_null_expr
= gfc_finish_block (&block
);
8153 gfc_start_block (&block
);
8154 gfc_conv_descriptor_data_set (&block
, dest
,
8156 null_expr
= gfc_finish_block (&block
);
8157 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
8158 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
8159 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8160 return build3_v (COND_EXPR
, tmp
,
8161 null_expr
, non_null_expr
);
8165 return gfc_finish_block (&block
);
8169 /* Allocate or reallocate scalar component, as necessary. */
8172 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
8182 tree lhs_cl_size
= NULL_TREE
;
8187 if (!expr2
|| expr2
->rank
)
8190 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8192 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8194 char name
[GFC_MAX_SYMBOL_LEN
+9];
8195 gfc_component
*strlen
;
8196 /* Use the rhs string length and the lhs element size. */
8197 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8198 if (!expr2
->ts
.u
.cl
->backend_decl
)
8200 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
8201 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
8204 size
= expr2
->ts
.u
.cl
->backend_decl
;
8206 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8208 sprintf (name
, "_%s_length", cm
->name
);
8209 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
8210 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
8211 gfc_charlen_type_node
,
8212 TREE_OPERAND (comp
, 0),
8213 strlen
->backend_decl
, NULL_TREE
);
8215 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8216 tmp
= TYPE_SIZE_UNIT (tmp
);
8217 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8218 TREE_TYPE (tmp
), tmp
,
8219 fold_convert (TREE_TYPE (tmp
), size
));
8221 else if (cm
->ts
.type
== BT_CLASS
)
8223 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8224 if (expr2
->ts
.type
== BT_DERIVED
)
8226 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8227 size
= TYPE_SIZE_UNIT (tmp
);
8233 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8234 gfc_add_vptr_component (e2vtab
);
8235 gfc_add_size_component (e2vtab
);
8236 gfc_init_se (&se
, NULL
);
8237 gfc_conv_expr (&se
, e2vtab
);
8238 gfc_add_block_to_block (block
, &se
.pre
);
8239 size
= fold_convert (size_type_node
, se
.expr
);
8240 gfc_free_expr (e2vtab
);
8242 size_in_bytes
= size
;
8246 /* Otherwise use the length in bytes of the rhs. */
8247 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8248 size_in_bytes
= size
;
8251 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8252 size_in_bytes
, size_one_node
);
8254 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8256 tmp
= build_call_expr_loc (input_location
,
8257 builtin_decl_explicit (BUILT_IN_CALLOC
),
8258 2, build_one_cst (size_type_node
),
8260 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8261 gfc_add_modify (block
, comp
, tmp
);
8265 tmp
= build_call_expr_loc (input_location
,
8266 builtin_decl_explicit (BUILT_IN_MALLOC
),
8268 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8269 ptr
= gfc_class_data_get (comp
);
8272 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8273 gfc_add_modify (block
, ptr
, tmp
);
8276 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8277 /* Update the lhs character length. */
8278 gfc_add_modify (block
, lhs_cl_size
,
8279 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8283 /* Assign a single component of a derived type constructor. */
8286 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8287 gfc_symbol
*sym
, bool init
)
8295 gfc_start_block (&block
);
8297 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8299 /* Only care about pointers here, not about allocatables. */
8300 gfc_init_se (&se
, NULL
);
8301 /* Pointer component. */
8302 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8303 && !cm
->attr
.proc_pointer
)
8305 /* Array pointer. */
8306 if (expr
->expr_type
== EXPR_NULL
)
8307 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8310 se
.direct_byref
= 1;
8312 gfc_conv_expr_descriptor (&se
, expr
);
8313 gfc_add_block_to_block (&block
, &se
.pre
);
8314 gfc_add_block_to_block (&block
, &se
.post
);
8319 /* Scalar pointers. */
8320 se
.want_pointer
= 1;
8321 gfc_conv_expr (&se
, expr
);
8322 gfc_add_block_to_block (&block
, &se
.pre
);
8324 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8325 && expr
->symtree
->n
.sym
->attr
.dummy
)
8326 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8328 gfc_add_modify (&block
, dest
,
8329 fold_convert (TREE_TYPE (dest
), se
.expr
));
8330 gfc_add_block_to_block (&block
, &se
.post
);
8333 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8335 /* NULL initialization for CLASS components. */
8336 tmp
= gfc_trans_structure_assign (dest
,
8337 gfc_class_initializer (&cm
->ts
, expr
),
8339 gfc_add_expr_to_block (&block
, tmp
);
8341 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8342 && !cm
->attr
.proc_pointer
)
8344 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8345 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8346 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8348 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8349 gfc_add_expr_to_block (&block
, tmp
);
8353 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8354 gfc_add_expr_to_block (&block
, tmp
);
8357 else if (cm
->ts
.type
== BT_CLASS
8358 && CLASS_DATA (cm
)->attr
.dimension
8359 && CLASS_DATA (cm
)->attr
.allocatable
8360 && expr
->ts
.type
== BT_DERIVED
)
8362 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8363 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8364 tmp
= gfc_class_vptr_get (dest
);
8365 gfc_add_modify (&block
, tmp
,
8366 fold_convert (TREE_TYPE (tmp
), vtab
));
8367 tmp
= gfc_class_data_get (dest
);
8368 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8369 gfc_add_expr_to_block (&block
, tmp
);
8371 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8373 /* NULL initialization for allocatable components. */
8374 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8375 null_pointer_node
));
8377 else if (init
&& (cm
->attr
.allocatable
8378 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8379 && expr
->ts
.type
!= BT_CLASS
)))
8381 /* Take care about non-array allocatable components here. The alloc_*
8382 routine below is motivated by the alloc_scalar_allocatable_for_
8383 assignment() routine, but with the realloc portions removed and
8385 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8390 /* The remainder of these instructions follow the if (cm->attr.pointer)
8391 if (!cm->attr.dimension) part above. */
8392 gfc_init_se (&se
, NULL
);
8393 gfc_conv_expr (&se
, expr
);
8394 gfc_add_block_to_block (&block
, &se
.pre
);
8396 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8397 && expr
->symtree
->n
.sym
->attr
.dummy
)
8398 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8400 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8402 tmp
= gfc_class_data_get (dest
);
8403 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8404 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8405 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8406 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8407 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8410 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8412 /* For deferred strings insert a memcpy. */
8413 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8416 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8417 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8419 : expr
->ts
.u
.cl
->backend_decl
);
8420 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8421 gfc_add_expr_to_block (&block
, tmp
);
8424 gfc_add_modify (&block
, tmp
,
8425 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8426 gfc_add_block_to_block (&block
, &se
.post
);
8428 else if (expr
->ts
.type
== BT_UNION
)
8431 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8432 /* We mark that the entire union should be initialized with a contrived
8433 EXPR_NULL expression at the beginning. */
8434 if (c
!= NULL
&& c
->n
.component
== NULL
8435 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8437 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8438 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8439 gfc_add_expr_to_block (&block
, tmp
);
8440 c
= gfc_constructor_next (c
);
8442 /* The following constructor expression, if any, represents a specific
8443 map intializer, as given by the user. */
8444 if (c
!= NULL
&& c
->expr
!= NULL
)
8446 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8447 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8448 gfc_add_expr_to_block (&block
, tmp
);
8451 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8453 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8455 tree dealloc
= NULL_TREE
;
8456 gfc_init_se (&se
, NULL
);
8457 gfc_conv_expr (&se
, expr
);
8458 gfc_add_block_to_block (&block
, &se
.pre
);
8459 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8460 expression in a temporary variable and deallocate the allocatable
8461 components. Then we can the copy the expression to the result. */
8462 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8463 && expr
->expr_type
!= EXPR_VARIABLE
)
8465 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8466 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8469 gfc_add_modify (&block
, dest
,
8470 fold_convert (TREE_TYPE (dest
), se
.expr
));
8471 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8472 && expr
->expr_type
!= EXPR_NULL
)
8474 // TODO: Fix caf_mode
8475 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8476 dest
, expr
->rank
, 0);
8477 gfc_add_expr_to_block (&block
, tmp
);
8478 if (dealloc
!= NULL_TREE
)
8479 gfc_add_expr_to_block (&block
, dealloc
);
8481 gfc_add_block_to_block (&block
, &se
.post
);
8485 /* Nested constructors. */
8486 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8487 gfc_add_expr_to_block (&block
, tmp
);
8490 else if (gfc_deferred_strlen (cm
, &tmp
))
8494 gcc_assert (strlen
);
8495 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8497 TREE_OPERAND (dest
, 0),
8500 if (expr
->expr_type
== EXPR_NULL
)
8502 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
8503 gfc_add_modify (&block
, dest
, tmp
);
8504 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
8505 gfc_add_modify (&block
, strlen
, tmp
);
8510 gfc_init_se (&se
, NULL
);
8511 gfc_conv_expr (&se
, expr
);
8512 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
8513 tmp
= build_call_expr_loc (input_location
,
8514 builtin_decl_explicit (BUILT_IN_MALLOC
),
8516 gfc_add_modify (&block
, dest
,
8517 fold_convert (TREE_TYPE (dest
), tmp
));
8518 gfc_add_modify (&block
, strlen
,
8519 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
8520 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
8521 gfc_add_expr_to_block (&block
, tmp
);
8524 else if (!cm
->attr
.artificial
)
8526 /* Scalar component (excluding deferred parameters). */
8527 gfc_init_se (&se
, NULL
);
8528 gfc_init_se (&lse
, NULL
);
8530 gfc_conv_expr (&se
, expr
);
8531 if (cm
->ts
.type
== BT_CHARACTER
)
8532 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8534 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
8535 gfc_add_expr_to_block (&block
, tmp
);
8537 return gfc_finish_block (&block
);
8540 /* Assign a derived type constructor to a variable. */
8543 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
8552 gfc_start_block (&block
);
8554 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
8555 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
8556 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
8560 gfc_init_se (&se
, NULL
);
8561 gfc_init_se (&lse
, NULL
);
8562 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
8564 gfc_add_modify (&block
, lse
.expr
,
8565 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
8567 return gfc_finish_block (&block
);
8570 /* Make sure that the derived type has been completely built. */
8571 if (!expr
->ts
.u
.derived
->backend_decl
8572 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
8574 tmp
= gfc_typenode_for_spec (&expr
->ts
);
8578 cm
= expr
->ts
.u
.derived
->components
;
8582 gfc_init_se (&se
, NULL
);
8584 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8585 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8587 /* Skip absent members in default initializers. */
8588 if (!c
->expr
&& !cm
->attr
.allocatable
)
8591 /* Register the component with the caf-lib before it is initialized.
8592 Register only allocatable components, that are not coarray'ed
8593 components (%comp[*]). Only register when the constructor is not the
8595 if (coarray
&& !cm
->attr
.codimension
8596 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
8597 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
8599 tree token
, desc
, size
;
8600 bool is_array
= cm
->ts
.type
== BT_CLASS
8601 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
8603 field
= cm
->backend_decl
;
8604 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
8605 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
8606 if (cm
->ts
.type
== BT_CLASS
)
8607 field
= gfc_class_data_get (field
);
8609 token
= is_array
? gfc_conv_descriptor_token (field
)
8610 : fold_build3_loc (input_location
, COMPONENT_REF
,
8611 TREE_TYPE (cm
->caf_token
), dest
,
8612 cm
->caf_token
, NULL_TREE
);
8616 /* The _caf_register routine looks at the rank of the array
8617 descriptor to decide whether the data registered is an array
8619 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
8621 /* When the rank is not known just set a positive rank, which
8622 suffices to recognize the data as array. */
8625 size
= build_zero_cst (size_type_node
);
8627 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
8628 build_int_cst (signed_char_type_node
, rank
));
8632 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8633 cm
->ts
.type
== BT_CLASS
8634 ? CLASS_DATA (cm
)->attr
8636 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8638 gfc_add_block_to_block (&block
, &se
.pre
);
8639 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8640 7, size
, build_int_cst (
8642 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8643 gfc_build_addr_expr (pvoid_type_node
,
8645 gfc_build_addr_expr (NULL_TREE
, desc
),
8646 null_pointer_node
, null_pointer_node
,
8648 gfc_add_expr_to_block (&block
, tmp
);
8650 field
= cm
->backend_decl
;
8652 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8653 dest
, field
, NULL_TREE
);
8656 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8657 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8662 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8663 expr
->ts
.u
.derived
, init
);
8664 gfc_add_expr_to_block (&block
, tmp
);
8666 return gfc_finish_block (&block
);
8670 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8671 gfc_component
*un
, gfc_expr
*init
)
8673 gfc_constructor
*ctor
;
8675 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8678 ctor
= gfc_constructor_first (init
->value
.constructor
);
8680 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8683 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8685 /* If we have an 'initialize all' constructor, do it first. */
8686 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8688 tree union_type
= TREE_TYPE (un
->backend_decl
);
8689 tree val
= build_constructor (union_type
, NULL
);
8690 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8691 ctor
= gfc_constructor_next (ctor
);
8694 /* Add the map initializer on top. */
8695 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8697 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8698 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8699 TREE_TYPE (un
->backend_decl
),
8700 un
->attr
.dimension
, un
->attr
.pointer
,
8701 un
->attr
.proc_pointer
);
8702 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8706 /* Build an expression for a constructor. If init is nonzero then
8707 this is part of a static variable initializer. */
8710 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8717 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8719 gcc_assert (se
->ss
== NULL
);
8720 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8721 type
= gfc_typenode_for_spec (&expr
->ts
);
8725 /* Create a temporary variable and fill it in. */
8726 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8727 /* The symtree in expr is NULL, if the code to generate is for
8728 initializing the static members only. */
8729 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8731 gfc_add_expr_to_block (&se
->pre
, tmp
);
8735 cm
= expr
->ts
.u
.derived
->components
;
8737 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8738 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8740 /* Skip absent members in default initializers and allocatable
8741 components. Although the latter have a default initializer
8742 of EXPR_NULL,... by default, the static nullify is not needed
8743 since this is done every time we come into scope. */
8744 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8747 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8748 && strcmp (cm
->name
, "_extends") == 0
8749 && cm
->initializer
->symtree
)
8753 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8754 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8755 vtab
= unshare_expr_without_location (vtab
);
8756 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8758 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8760 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8761 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8762 fold_convert (TREE_TYPE (cm
->backend_decl
),
8765 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8766 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8767 fold_convert (TREE_TYPE (cm
->backend_decl
),
8768 integer_zero_node
));
8769 else if (cm
->ts
.type
== BT_UNION
)
8770 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8773 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8774 TREE_TYPE (cm
->backend_decl
),
8775 cm
->attr
.dimension
, cm
->attr
.pointer
,
8776 cm
->attr
.proc_pointer
);
8777 val
= unshare_expr_without_location (val
);
8779 /* Append it to the constructor list. */
8780 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8784 se
->expr
= build_constructor (type
, v
);
8786 TREE_CONSTANT (se
->expr
) = 1;
8790 /* Translate a substring expression. */
8793 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8799 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8801 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8802 expr
->value
.character
.length
,
8803 expr
->value
.character
.string
);
8805 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8806 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8809 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8813 /* Entry point for expression translation. Evaluates a scalar quantity.
8814 EXPR is the expression to be translated, and SE is the state structure if
8815 called from within the scalarized. */
8818 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8823 if (ss
&& ss
->info
->expr
== expr
8824 && (ss
->info
->type
== GFC_SS_SCALAR
8825 || ss
->info
->type
== GFC_SS_REFERENCE
))
8827 gfc_ss_info
*ss_info
;
8830 /* Substitute a scalar expression evaluated outside the scalarization
8832 se
->expr
= ss_info
->data
.scalar
.value
;
8833 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8834 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8836 se
->string_length
= ss_info
->string_length
;
8837 gfc_advance_se_ss_chain (se
);
8841 /* We need to convert the expressions for the iso_c_binding derived types.
8842 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8843 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8844 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8845 updated to be an integer with a kind equal to the size of a (void *). */
8846 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8847 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8849 if (expr
->expr_type
== EXPR_VARIABLE
8850 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8851 || expr
->symtree
->n
.sym
->intmod_sym_id
8852 == ISOCBINDING_NULL_FUNPTR
))
8854 /* Set expr_type to EXPR_NULL, which will result in
8855 null_pointer_node being used below. */
8856 expr
->expr_type
= EXPR_NULL
;
8860 /* Update the type/kind of the expression to be what the new
8861 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8862 expr
->ts
.type
= BT_INTEGER
;
8863 expr
->ts
.f90_type
= BT_VOID
;
8864 expr
->ts
.kind
= gfc_index_integer_kind
;
8868 gfc_fix_class_refs (expr
);
8870 switch (expr
->expr_type
)
8873 gfc_conv_expr_op (se
, expr
);
8877 gfc_conv_function_expr (se
, expr
);
8881 gfc_conv_constant (se
, expr
);
8885 gfc_conv_variable (se
, expr
);
8889 se
->expr
= null_pointer_node
;
8892 case EXPR_SUBSTRING
:
8893 gfc_conv_substring_expr (se
, expr
);
8896 case EXPR_STRUCTURE
:
8897 gfc_conv_structure (se
, expr
, 0);
8901 gfc_conv_array_constructor_expr (se
, expr
);
8910 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8911 of an assignment. */
8913 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8915 gfc_conv_expr (se
, expr
);
8916 /* All numeric lvalues should have empty post chains. If not we need to
8917 figure out a way of rewriting an lvalue so that it has no post chain. */
8918 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8921 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8922 numeric expressions. Used for scalar values where inserting cleanup code
8925 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8929 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8930 gfc_conv_expr (se
, expr
);
8933 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8934 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8936 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8940 /* Helper to translate an expression and convert it to a particular type. */
8942 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8944 gfc_conv_expr_val (se
, expr
);
8945 se
->expr
= convert (type
, se
->expr
);
8949 /* Converts an expression so that it can be passed by reference. Scalar
8953 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8959 if (ss
&& ss
->info
->expr
== expr
8960 && ss
->info
->type
== GFC_SS_REFERENCE
)
8962 /* Returns a reference to the scalar evaluated outside the loop
8964 gfc_conv_expr (se
, expr
);
8966 if (expr
->ts
.type
== BT_CHARACTER
8967 && expr
->expr_type
!= EXPR_FUNCTION
)
8968 gfc_conv_string_parameter (se
);
8970 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8975 if (expr
->ts
.type
== BT_CHARACTER
)
8977 gfc_conv_expr (se
, expr
);
8978 gfc_conv_string_parameter (se
);
8982 if (expr
->expr_type
== EXPR_VARIABLE
)
8984 se
->want_pointer
= 1;
8985 gfc_conv_expr (se
, expr
);
8988 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8989 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8990 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8993 else if (add_clobber
&& expr
->ref
== NULL
)
8997 /* FIXME: This fails if var is passed by reference, see PR
8999 var
= expr
->symtree
->n
.sym
->backend_decl
;
9000 clobber
= build_clobber (TREE_TYPE (var
));
9001 gfc_add_modify (&se
->pre
, var
, clobber
);
9006 if (expr
->expr_type
== EXPR_FUNCTION
9007 && ((expr
->value
.function
.esym
9008 && expr
->value
.function
.esym
->result
9009 && expr
->value
.function
.esym
->result
->attr
.pointer
9010 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
9011 || (!expr
->value
.function
.esym
&& !expr
->ref
9012 && expr
->symtree
->n
.sym
->attr
.pointer
9013 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
9015 se
->want_pointer
= 1;
9016 gfc_conv_expr (se
, expr
);
9017 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9018 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9023 gfc_conv_expr (se
, expr
);
9025 /* Create a temporary var to hold the value. */
9026 if (TREE_CONSTANT (se
->expr
))
9028 tree tmp
= se
->expr
;
9029 STRIP_TYPE_NOPS (tmp
);
9030 var
= build_decl (input_location
,
9031 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
9032 DECL_INITIAL (var
) = tmp
;
9033 TREE_STATIC (var
) = 1;
9038 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9039 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9042 if (!expr
->must_finalize
)
9043 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9045 /* Take the address of that value. */
9046 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
9050 /* Get the _len component for an unlimited polymorphic expression. */
9053 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
9056 gfc_ref
*ref
= expr
->ref
;
9058 gfc_init_se (&se
, NULL
);
9059 while (ref
&& ref
->next
)
9061 gfc_add_len_component (expr
);
9062 gfc_conv_expr (&se
, expr
);
9063 gfc_add_block_to_block (block
, &se
.pre
);
9064 gcc_assert (se
.post
.head
== NULL_TREE
);
9067 gfc_free_ref_list (ref
->next
);
9072 gfc_free_ref_list (expr
->ref
);
9079 /* Assign _vptr and _len components as appropriate. BLOCK should be a
9080 statement-list outside of the scalarizer-loop. When code is generated, that
9081 depends on the scalarized expression, it is added to RSE.PRE.
9082 Returns le's _vptr tree and when set the len expressions in to_lenp and
9083 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9087 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
9088 gfc_expr
* re
, gfc_se
*rse
,
9089 tree
* to_lenp
, tree
* from_lenp
)
9092 gfc_expr
* vptr_expr
;
9093 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
9094 bool set_vptr
= false, temp_rhs
= false;
9095 stmtblock_t
*pre
= block
;
9096 tree class_expr
= NULL_TREE
;
9098 /* Create a temporary for complicated expressions. */
9099 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
9100 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
9102 if (re
->ts
.type
== BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9103 class_expr
= gfc_get_class_from_expr (rse
->expr
);
9106 pre
= &rse
->loop
->pre
;
9110 if (class_expr
!= NULL_TREE
&& UNLIMITED_POLY (re
))
9112 tmp
= TREE_OPERAND (rse
->expr
, 0);
9113 tmp
= gfc_create_var (TREE_TYPE (tmp
), "rhs");
9114 gfc_add_modify (&rse
->pre
, tmp
, TREE_OPERAND (rse
->expr
, 0));
9118 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
9119 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
9126 /* Get the _vptr for the left-hand side expression. */
9127 gfc_init_se (&se
, NULL
);
9128 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
9129 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
9131 /* Care about _len for unlimited polymorphic entities. */
9132 if (UNLIMITED_POLY (vptr_expr
)
9133 || (vptr_expr
->ts
.type
== BT_DERIVED
9134 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9135 to_len
= trans_get_upoly_len (block
, vptr_expr
);
9136 gfc_add_vptr_component (vptr_expr
);
9140 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9141 se
.want_pointer
= 1;
9142 gfc_conv_expr (&se
, vptr_expr
);
9143 gfc_free_expr (vptr_expr
);
9144 gfc_add_block_to_block (block
, &se
.pre
);
9145 gcc_assert (se
.post
.head
== NULL_TREE
);
9147 STRIP_NOPS (lhs_vptr
);
9149 /* Set the _vptr only when the left-hand side of the assignment is a
9153 /* Get the vptr from the rhs expression only, when it is variable.
9154 Functions are expected to be assigned to a temporary beforehand. */
9155 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
9156 ? gfc_find_and_cut_at_last_class_ref (re
)
9158 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
9160 if (to_len
!= NULL_TREE
)
9162 /* Get the _len information from the rhs. */
9163 if (UNLIMITED_POLY (vptr_expr
)
9164 || (vptr_expr
->ts
.type
== BT_DERIVED
9165 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9166 from_len
= trans_get_upoly_len (block
, vptr_expr
);
9168 gfc_add_vptr_component (vptr_expr
);
9172 if (re
->expr_type
== EXPR_VARIABLE
9173 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
9174 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
9175 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
9176 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
9177 re
->symtree
->n
.sym
->backend_decl
))))
9180 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
9181 re
->symtree
->n
.sym
->backend_decl
));
9183 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
9184 re
->symtree
->n
.sym
->backend_decl
));
9186 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
9191 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9192 tmp
= gfc_get_class_from_expr (rse
->expr
);
9196 se
.expr
= gfc_class_vptr_get (tmp
);
9197 if (UNLIMITED_POLY (re
))
9198 from_len
= gfc_class_len_get (tmp
);
9201 else if (re
->expr_type
!= EXPR_NULL
)
9202 /* Only when rhs is non-NULL use its declared type for vptr
9204 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
9206 /* When the rhs is NULL use the vtab of lhs' declared type. */
9207 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9212 gfc_init_se (&se
, NULL
);
9213 se
.want_pointer
= 1;
9214 gfc_conv_expr (&se
, vptr_expr
);
9215 gfc_free_expr (vptr_expr
);
9216 gfc_add_block_to_block (block
, &se
.pre
);
9217 gcc_assert (se
.post
.head
== NULL_TREE
);
9219 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
9222 if (to_len
!= NULL_TREE
)
9224 /* The _len component needs to be set. Figure how to get the
9225 value of the right-hand side. */
9226 if (from_len
== NULL_TREE
)
9228 if (rse
->string_length
!= NULL_TREE
)
9229 from_len
= rse
->string_length
;
9230 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
9232 gfc_init_se (&se
, NULL
);
9233 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
9234 gfc_add_block_to_block (block
, &se
.pre
);
9235 gcc_assert (se
.post
.head
== NULL_TREE
);
9236 from_len
= gfc_evaluate_now (se
.expr
, block
);
9239 from_len
= build_zero_cst (gfc_charlen_type_node
);
9241 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9246 /* Return the _len trees only, when requested. */
9250 *from_lenp
= from_len
;
9255 /* Assign tokens for pointer components. */
9258 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9261 symbol_attribute lhs_attr
, rhs_attr
;
9262 tree tmp
, lhs_tok
, rhs_tok
;
9263 /* Flag to indicated component refs on the rhs. */
9266 lhs_attr
= gfc_caf_attr (expr1
);
9267 if (expr2
->expr_type
!= EXPR_NULL
)
9269 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9270 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9272 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9273 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9276 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9280 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9281 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9284 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9286 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9287 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9290 else if (lhs_attr
.codimension
)
9292 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9293 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9294 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9295 lhs_tok
, null_pointer_node
);
9296 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9301 /* Do everything that is needed for a CLASS function expr2. */
9304 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9305 gfc_expr
*expr1
, gfc_expr
*expr2
)
9307 tree expr1_vptr
= NULL_TREE
;
9310 gfc_conv_function_expr (rse
, expr2
);
9311 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9313 if (expr1
->ts
.type
!= BT_CLASS
)
9314 rse
->expr
= gfc_class_data_get (rse
->expr
);
9317 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9320 gfc_add_block_to_block (block
, &rse
->pre
);
9321 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9322 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9324 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9325 fold_convert (TREE_TYPE (expr1_vptr
),
9326 gfc_class_vptr_get (tmp
)));
9327 rse
->expr
= gfc_class_data_get (tmp
);
9335 gfc_trans_pointer_assign (gfc_code
* code
)
9337 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9341 /* Generate code for a pointer assignment. */
9344 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9351 tree expr1_vptr
= NULL_TREE
;
9352 bool scalar
, non_proc_ptr_assign
;
9355 gfc_start_block (&block
);
9357 gfc_init_se (&lse
, NULL
);
9359 /* Usually testing whether this is not a proc pointer assignment. */
9360 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9361 && expr2
->expr_type
== EXPR_VARIABLE
9362 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9364 /* Check whether the expression is a scalar or not; we cannot use
9365 expr1->rank as it can be nonzero for proc pointers. */
9366 ss
= gfc_walk_expr (expr1
);
9367 scalar
= ss
== gfc_ss_terminator
;
9369 gfc_free_ss_chain (ss
);
9371 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9372 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9374 gfc_add_data_component (expr2
);
9375 /* The following is required as gfc_add_data_component doesn't
9376 update ts.type if there is a tailing REF_ARRAY. */
9377 expr2
->ts
.type
= BT_DERIVED
;
9382 /* Scalar pointers. */
9383 lse
.want_pointer
= 1;
9384 gfc_conv_expr (&lse
, expr1
);
9385 gfc_init_se (&rse
, NULL
);
9386 rse
.want_pointer
= 1;
9387 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9388 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9390 gfc_conv_expr (&rse
, expr2
);
9392 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9394 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9396 lse
.expr
= gfc_class_data_get (lse
.expr
);
9399 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9400 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9401 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9404 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9405 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9406 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9409 gfc_add_block_to_block (&block
, &lse
.pre
);
9410 gfc_add_block_to_block (&block
, &rse
.pre
);
9412 /* Check character lengths if character expression. The test is only
9413 really added if -fbounds-check is enabled. Exclude deferred
9414 character length lefthand sides. */
9415 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9416 && !expr1
->ts
.deferred
9417 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9418 && !gfc_is_proc_ptr_comp (expr1
))
9420 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9421 gcc_assert (lse
.string_length
&& rse
.string_length
);
9422 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9423 lse
.string_length
, rse
.string_length
,
9427 /* The assignment to an deferred character length sets the string
9428 length to that of the rhs. */
9429 if (expr1
->ts
.deferred
)
9431 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9432 gfc_add_modify (&block
, lse
.string_length
,
9433 fold_convert (TREE_TYPE (lse
.string_length
),
9434 rse
.string_length
));
9435 else if (lse
.string_length
!= NULL
)
9436 gfc_add_modify (&block
, lse
.string_length
,
9437 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9440 gfc_add_modify (&block
, lse
.expr
,
9441 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9443 /* Also set the tokens for pointer components in derived typed
9445 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9446 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9448 gfc_add_block_to_block (&block
, &rse
.post
);
9449 gfc_add_block_to_block (&block
, &lse
.post
);
9456 tree strlen_rhs
= NULL_TREE
;
9458 /* Array pointer. Find the last reference on the LHS and if it is an
9459 array section ref, we're dealing with bounds remapping. In this case,
9460 set it to AR_FULL so that gfc_conv_expr_descriptor does
9461 not see it and process the bounds remapping afterwards explicitly. */
9462 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9463 if (!remap
->next
&& remap
->type
== REF_ARRAY
9464 && remap
->u
.ar
.type
== AR_SECTION
)
9466 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9468 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
9470 gfc_error ("If bounds remapping is specified at %L, "
9471 "the pointer target shall not be NULL", &expr1
->where
);
9475 gfc_init_se (&lse
, NULL
);
9477 lse
.descriptor_only
= 1;
9478 gfc_conv_expr_descriptor (&lse
, expr1
);
9479 strlen_lhs
= lse
.string_length
;
9482 if (expr2
->expr_type
== EXPR_NULL
)
9484 /* Just set the data pointer to null. */
9485 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9487 else if (rank_remap
)
9489 /* If we are rank-remapping, just get the RHS's descriptor and
9490 process this later on. */
9491 gfc_init_se (&rse
, NULL
);
9492 rse
.direct_byref
= 1;
9493 rse
.byref_noassign
= 1;
9495 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9496 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
9498 else if (expr2
->expr_type
== EXPR_FUNCTION
)
9500 tree bound
[GFC_MAX_DIMENSIONS
];
9503 for (i
= 0; i
< expr2
->rank
; i
++)
9504 bound
[i
] = NULL_TREE
;
9505 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
9506 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
9508 GFC_ARRAY_POINTER_CONT
, false);
9509 tmp
= gfc_create_var (tmp
, "ptrtemp");
9510 rse
.descriptor_only
= 0;
9512 rse
.direct_byref
= 1;
9513 gfc_conv_expr_descriptor (&rse
, expr2
);
9514 strlen_rhs
= rse
.string_length
;
9519 gfc_conv_expr_descriptor (&rse
, expr2
);
9520 strlen_rhs
= rse
.string_length
;
9521 if (expr1
->ts
.type
== BT_CLASS
)
9522 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9527 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9529 /* Assign directly to the LHS's descriptor. */
9530 lse
.descriptor_only
= 0;
9531 lse
.direct_byref
= 1;
9532 gfc_conv_expr_descriptor (&lse
, expr2
);
9533 strlen_rhs
= lse
.string_length
;
9535 if (expr1
->ts
.type
== BT_CLASS
)
9537 rse
.expr
= NULL_TREE
;
9538 rse
.string_length
= NULL_TREE
;
9539 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
9545 /* If the target is not a whole array, use the target array
9546 reference for remap. */
9547 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
9548 if (remap
->type
== REF_ARRAY
9549 && remap
->u
.ar
.type
== AR_FULL
9554 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9556 gfc_init_se (&rse
, NULL
);
9557 rse
.want_pointer
= 1;
9558 gfc_conv_function_expr (&rse
, expr2
);
9559 if (expr1
->ts
.type
!= BT_CLASS
)
9561 rse
.expr
= gfc_class_data_get (rse
.expr
);
9562 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9563 /* Set the lhs span. */
9564 tmp
= TREE_TYPE (rse
.expr
);
9565 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9566 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9567 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
9571 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9574 gfc_add_block_to_block (&block
, &rse
.pre
);
9575 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
9576 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
9578 gfc_add_modify (&lse
.pre
, expr1_vptr
,
9579 fold_convert (TREE_TYPE (expr1_vptr
),
9580 gfc_class_vptr_get (tmp
)));
9581 rse
.expr
= gfc_class_data_get (tmp
);
9582 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9587 /* Assign to a temporary descriptor and then copy that
9588 temporary to the pointer. */
9589 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
9590 lse
.descriptor_only
= 0;
9592 lse
.direct_byref
= 1;
9593 gfc_conv_expr_descriptor (&lse
, expr2
);
9594 strlen_rhs
= lse
.string_length
;
9595 gfc_add_modify (&lse
.pre
, desc
, tmp
);
9598 gfc_add_block_to_block (&block
, &lse
.pre
);
9600 gfc_add_block_to_block (&block
, &rse
.pre
);
9602 /* If we do bounds remapping, update LHS descriptor accordingly. */
9606 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
9610 /* Do rank remapping. We already have the RHS's descriptor
9611 converted in rse and now have to build the correct LHS
9612 descriptor for it. */
9614 tree dtype
, data
, span
;
9616 tree lbound
, ubound
;
9619 dtype
= gfc_conv_descriptor_dtype (desc
);
9620 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
9621 gfc_add_modify (&block
, dtype
, tmp
);
9623 /* Copy data pointer. */
9624 data
= gfc_conv_descriptor_data_get (rse
.expr
);
9625 gfc_conv_descriptor_data_set (&block
, desc
, data
);
9627 /* Copy the span. */
9628 if (TREE_CODE (rse
.expr
) == VAR_DECL
9629 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
9630 span
= gfc_conv_descriptor_span_get (rse
.expr
);
9633 tmp
= TREE_TYPE (rse
.expr
);
9634 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9635 span
= fold_convert (gfc_array_index_type
, tmp
);
9637 gfc_conv_descriptor_span_set (&block
, desc
, span
);
9639 /* Copy offset but adjust it such that it would correspond
9640 to a lbound of zero. */
9641 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
9642 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
9644 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9646 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
9648 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9649 gfc_array_index_type
, stride
, lbound
);
9650 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9651 gfc_array_index_type
, offs
, tmp
);
9653 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9655 /* Set the bounds as declared for the LHS and calculate strides as
9656 well as another offset update accordingly. */
9657 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9659 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9664 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9666 /* Convert declared bounds. */
9667 gfc_init_se (&lower_se
, NULL
);
9668 gfc_init_se (&upper_se
, NULL
);
9669 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9670 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9672 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9673 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9675 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9676 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9678 lbound
= gfc_evaluate_now (lbound
, &block
);
9679 ubound
= gfc_evaluate_now (ubound
, &block
);
9681 gfc_add_block_to_block (&block
, &lower_se
.post
);
9682 gfc_add_block_to_block (&block
, &upper_se
.post
);
9684 /* Set bounds in descriptor. */
9685 gfc_conv_descriptor_lbound_set (&block
, desc
,
9686 gfc_rank_cst
[dim
], lbound
);
9687 gfc_conv_descriptor_ubound_set (&block
, desc
,
9688 gfc_rank_cst
[dim
], ubound
);
9691 stride
= gfc_evaluate_now (stride
, &block
);
9692 gfc_conv_descriptor_stride_set (&block
, desc
,
9693 gfc_rank_cst
[dim
], stride
);
9695 /* Update offset. */
9696 offs
= gfc_conv_descriptor_offset_get (desc
);
9697 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9698 gfc_array_index_type
, lbound
, stride
);
9699 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9700 gfc_array_index_type
, offs
, tmp
);
9701 offs
= gfc_evaluate_now (offs
, &block
);
9702 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9704 /* Update stride. */
9705 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9706 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9707 gfc_array_index_type
, stride
, tmp
);
9712 /* Bounds remapping. Just shift the lower bounds. */
9714 gcc_assert (expr1
->rank
== expr2
->rank
);
9716 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9720 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9721 gfc_init_se (&lbound_se
, NULL
);
9722 if (remap
->u
.ar
.start
[dim
])
9724 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9725 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9728 /* This remap arises from a target that is not a whole
9729 array. The start expressions will be NULL but we need
9730 the lbounds to be one. */
9731 lbound_se
.expr
= gfc_index_one_node
;
9732 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9733 dim
, lbound_se
.expr
);
9734 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9739 /* If rank remapping was done, check with -fcheck=bounds that
9740 the target is at least as large as the pointer. */
9741 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9747 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9748 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9750 lsize
= gfc_evaluate_now (lsize
, &block
);
9751 rsize
= gfc_evaluate_now (rsize
, &block
);
9752 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9755 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9756 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9760 if (expr1
->ts
.type
== BT_CHARACTER
9761 && expr1
->symtree
->n
.sym
->ts
.deferred
9762 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9763 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9765 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9766 if (expr2
->expr_type
!= EXPR_NULL
)
9767 gfc_add_modify (&block
, tmp
,
9768 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9770 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9773 /* Check string lengths if applicable. The check is only really added
9774 to the output code if -fbounds-check is enabled. */
9775 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9777 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9778 gcc_assert (strlen_lhs
&& strlen_rhs
);
9779 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9780 strlen_lhs
, strlen_rhs
, &block
);
9783 gfc_add_block_to_block (&block
, &lse
.post
);
9785 gfc_add_block_to_block (&block
, &rse
.post
);
9788 return gfc_finish_block (&block
);
9792 /* Makes sure se is suitable for passing as a function string parameter. */
9793 /* TODO: Need to check all callers of this function. It may be abused. */
9796 gfc_conv_string_parameter (gfc_se
* se
)
9800 if (TREE_CODE (se
->expr
) == STRING_CST
)
9802 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9803 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9807 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
9808 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
9809 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9811 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9813 type
= TREE_TYPE (se
->expr
);
9814 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9818 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9820 type
= build_pointer_type (type
);
9821 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9825 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9829 /* Generate code for assignment of scalar variables. Includes character
9830 strings and derived types with allocatable components.
9831 If you know that the LHS has no allocations, set dealloc to false.
9833 DEEP_COPY has no effect if the typespec TS is not a derived type with
9834 allocatable components. Otherwise, if it is set, an explicit copy of each
9835 allocatable component is made. This is necessary as a simple copy of the
9836 whole object would copy array descriptors as is, so that the lhs's
9837 allocatable components would point to the rhs's after the assignment.
9838 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9839 necessary if the rhs is a non-pointer function, as the allocatable components
9840 are not accessible by other means than the function's result after the
9841 function has returned. It is even more subtle when temporaries are involved,
9842 as the two following examples show:
9843 1. When we evaluate an array constructor, a temporary is created. Thus
9844 there is theoretically no alias possible. However, no deep copy is
9845 made for this temporary, so that if the constructor is made of one or
9846 more variable with allocatable components, those components still point
9847 to the variable's: DEEP_COPY should be set for the assignment from the
9848 temporary to the lhs in that case.
9849 2. When assigning a scalar to an array, we evaluate the scalar value out
9850 of the loop, store it into a temporary variable, and assign from that.
9851 In that case, deep copying when assigning to the temporary would be a
9852 waste of resources; however deep copies should happen when assigning from
9853 the temporary to each array element: again DEEP_COPY should be set for
9854 the assignment from the temporary to the lhs. */
9857 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9858 bool deep_copy
, bool dealloc
, bool in_coarray
)
9864 gfc_init_block (&block
);
9866 if (ts
.type
== BT_CHARACTER
)
9871 if (lse
->string_length
!= NULL_TREE
)
9873 gfc_conv_string_parameter (lse
);
9874 gfc_add_block_to_block (&block
, &lse
->pre
);
9875 llen
= lse
->string_length
;
9878 if (rse
->string_length
!= NULL_TREE
)
9880 gfc_conv_string_parameter (rse
);
9881 gfc_add_block_to_block (&block
, &rse
->pre
);
9882 rlen
= rse
->string_length
;
9885 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9886 rse
->expr
, ts
.kind
);
9888 else if (gfc_bt_struct (ts
.type
)
9889 && (ts
.u
.derived
->attr
.alloc_comp
9890 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9892 tree tmp_var
= NULL_TREE
;
9895 /* Are the rhs and the lhs the same? */
9898 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9899 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9900 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9901 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9904 /* Deallocate the lhs allocated components as long as it is not
9905 the same as the rhs. This must be done following the assignment
9906 to prevent deallocating data that could be used in the rhs
9910 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9911 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9913 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9915 gfc_add_expr_to_block (&lse
->post
, tmp
);
9918 gfc_add_block_to_block (&block
, &rse
->pre
);
9919 gfc_add_block_to_block (&block
, &lse
->pre
);
9921 gfc_add_modify (&block
, lse
->expr
,
9922 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9924 /* Restore pointer address of coarray components. */
9925 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9927 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9928 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9930 gfc_add_expr_to_block (&block
, tmp
);
9933 /* Do a deep copy if the rhs is a variable, if it is not the
9937 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9938 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9939 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9941 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9943 gfc_add_expr_to_block (&block
, tmp
);
9946 else if (gfc_bt_struct (ts
.type
))
9948 gfc_add_block_to_block (&block
, &lse
->pre
);
9949 gfc_add_block_to_block (&block
, &rse
->pre
);
9950 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9951 TREE_TYPE (lse
->expr
), rse
->expr
);
9952 gfc_add_modify (&block
, lse
->expr
, tmp
);
9954 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
9955 else if (ts
.type
== BT_CLASS
9956 && !trans_scalar_class_assign (&block
, lse
, rse
))
9958 gfc_add_block_to_block (&block
, &lse
->pre
);
9959 gfc_add_block_to_block (&block
, &rse
->pre
);
9960 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
9961 for the lhs which ensures that class data rhs cast as a string assigns
9963 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9964 TREE_TYPE (rse
->expr
), lse
->expr
);
9965 gfc_add_modify (&block
, tmp
, rse
->expr
);
9967 else if (ts
.type
!= BT_CLASS
)
9969 gfc_add_block_to_block (&block
, &lse
->pre
);
9970 gfc_add_block_to_block (&block
, &rse
->pre
);
9972 gfc_add_modify (&block
, lse
->expr
,
9973 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9976 gfc_add_block_to_block (&block
, &lse
->post
);
9977 gfc_add_block_to_block (&block
, &rse
->post
);
9979 return gfc_finish_block (&block
);
9983 /* There are quite a lot of restrictions on the optimisation in using an
9984 array function assign without a temporary. */
9987 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9990 bool seen_array_ref
;
9992 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9994 /* Play it safe with class functions assigned to a derived type. */
9995 if (gfc_is_class_array_function (expr2
)
9996 && expr1
->ts
.type
== BT_DERIVED
)
9999 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10000 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
10003 /* Elemental functions are scalarized so that they don't need a
10004 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10005 they would need special treatment in gfc_trans_arrayfunc_assign. */
10006 if (expr2
->value
.function
.esym
!= NULL
10007 && expr2
->value
.function
.esym
->attr
.elemental
)
10010 /* Need a temporary if rhs is not FULL or a contiguous section. */
10011 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
10014 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10015 if (gfc_ref_needs_temporary_p (expr1
->ref
))
10018 /* Functions returning pointers or allocatables need temporaries. */
10019 if (gfc_expr_attr (expr2
).pointer
10020 || gfc_expr_attr (expr2
).allocatable
)
10023 /* Character array functions need temporaries unless the
10024 character lengths are the same. */
10025 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
10027 if (expr1
->ts
.u
.cl
->length
== NULL
10028 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10031 if (expr2
->ts
.u
.cl
->length
== NULL
10032 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10035 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
10036 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
10040 /* Check that no LHS component references appear during an array
10041 reference. This is needed because we do not have the means to
10042 span any arbitrary stride with an array descriptor. This check
10043 is not needed for the rhs because the function result has to be
10044 a complete type. */
10045 seen_array_ref
= false;
10046 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10048 if (ref
->type
== REF_ARRAY
)
10049 seen_array_ref
= true;
10050 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
10054 /* Check for a dependency. */
10055 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
10056 expr2
->value
.function
.esym
,
10057 expr2
->value
.function
.actual
,
10061 /* If we have reached here with an intrinsic function, we do not
10062 need a temporary except in the particular case that reallocation
10063 on assignment is active and the lhs is allocatable and a target,
10064 or a pointer which may be a subref pointer. FIXME: The last
10065 condition can go away when we use span in the intrinsics
10067 if (expr2
->value
.function
.isym
)
10068 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
)
10069 || (sym
->attr
.pointer
&& sym
->attr
.subref_array_pointer
);
10071 /* If the LHS is a dummy, we need a temporary if it is not
10073 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
10076 /* If the lhs has been host_associated, is in common, a pointer or is
10077 a target and the function is not using a RESULT variable, aliasing
10078 can occur and a temporary is needed. */
10079 if ((sym
->attr
.host_assoc
10080 || sym
->attr
.in_common
10081 || sym
->attr
.pointer
10082 || sym
->attr
.cray_pointee
10083 || sym
->attr
.target
)
10084 && expr2
->symtree
!= NULL
10085 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
10088 /* A PURE function can unconditionally be called without a temporary. */
10089 if (expr2
->value
.function
.esym
!= NULL
10090 && expr2
->value
.function
.esym
->attr
.pure
)
10093 /* Implicit_pure functions are those which could legally be declared
10095 if (expr2
->value
.function
.esym
!= NULL
10096 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
10099 if (!sym
->attr
.use_assoc
10100 && !sym
->attr
.in_common
10101 && !sym
->attr
.pointer
10102 && !sym
->attr
.target
10103 && !sym
->attr
.cray_pointee
10104 && expr2
->value
.function
.esym
)
10106 /* A temporary is not needed if the function is not contained and
10107 the variable is local or host associated and not a pointer or
10109 if (!expr2
->value
.function
.esym
->attr
.contained
)
10112 /* A temporary is not needed if the lhs has never been host
10113 associated and the procedure is contained. */
10114 else if (!sym
->attr
.host_assoc
)
10117 /* A temporary is not needed if the variable is local and not
10118 a pointer, a target or a result. */
10119 if (sym
->ns
->parent
10120 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
10124 /* Default to temporary use. */
10129 /* Provide the loop info so that the lhs descriptor can be built for
10130 reallocatable assignments from extrinsic function calls. */
10133 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
10134 gfc_loopinfo
*loop
)
10136 /* Signal that the function call should not be made by
10137 gfc_conv_loop_setup. */
10138 se
->ss
->is_alloc_lhs
= 1;
10139 gfc_init_loopinfo (loop
);
10140 gfc_add_ss_to_loop (loop
, *ss
);
10141 gfc_add_ss_to_loop (loop
, se
->ss
);
10142 gfc_conv_ss_startstride (loop
);
10143 gfc_conv_loop_setup (loop
, where
);
10144 gfc_copy_loopinfo_to_se (se
, loop
);
10145 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
10146 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
10147 se
->ss
->is_alloc_lhs
= 0;
10151 /* For assignment to a reallocatable lhs from intrinsic functions,
10152 replace the se.expr (ie. the result) with a temporary descriptor.
10153 Null the data field so that the library allocates space for the
10154 result. Free the data of the original descriptor after the function,
10155 in case it appears in an argument expression and transfer the
10156 result to the original descriptor. */
10159 fcncall_realloc_result (gfc_se
*se
, int rank
)
10166 tree not_same_shape
;
10167 stmtblock_t shape_block
;
10170 /* Use the allocation done by the library. Substitute the lhs
10171 descriptor with a copy, whose data field is nulled.*/
10172 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
10173 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
10174 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
10176 /* Unallocated, the descriptor does not have a dtype. */
10177 tmp
= gfc_conv_descriptor_dtype (desc
);
10178 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10180 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
10181 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
10182 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
10184 /* Free the lhs after the function call and copy the result data to
10185 the lhs descriptor. */
10186 tmp
= gfc_conv_descriptor_data_get (desc
);
10187 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10188 logical_type_node
, tmp
,
10189 build_int_cst (TREE_TYPE (tmp
), 0));
10190 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
10191 tmp
= gfc_call_free (tmp
);
10192 gfc_add_expr_to_block (&se
->post
, tmp
);
10194 tmp
= gfc_conv_descriptor_data_get (res_desc
);
10195 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
10197 /* Check that the shapes are the same between lhs and expression.
10198 The evaluation of the shape is done in 'shape_block' to avoid
10199 unitialized warnings from the lhs bounds. */
10200 not_same_shape
= boolean_false_node
;
10201 gfc_start_block (&shape_block
);
10202 for (n
= 0 ; n
< rank
; n
++)
10205 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10206 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
10207 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10208 gfc_array_index_type
, tmp
, tmp1
);
10209 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10210 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10211 gfc_array_index_type
, tmp
, tmp1
);
10212 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10213 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10214 gfc_array_index_type
, tmp
, tmp1
);
10215 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10216 logical_type_node
, tmp
,
10217 gfc_index_zero_node
);
10218 tmp
= gfc_evaluate_now (tmp
, &shape_block
);
10220 not_same_shape
= tmp
;
10222 not_same_shape
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10223 logical_type_node
, tmp
,
10227 /* 'zero_cond' being true is equal to lhs not being allocated or the
10228 shapes being different. */
10229 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
10230 zero_cond
, not_same_shape
);
10231 gfc_add_modify (&shape_block
, zero_cond
, tmp
);
10232 tmp
= gfc_finish_block (&shape_block
);
10233 tmp
= build3_v (COND_EXPR
, zero_cond
,
10234 build_empty_stmt (input_location
), tmp
);
10235 gfc_add_expr_to_block (&se
->post
, tmp
);
10237 /* Now reset the bounds returned from the function call to bounds based
10238 on the lhs lbounds, except where the lhs is not allocated or the shapes
10239 of 'variable and 'expr' are different. Set the offset accordingly. */
10240 offset
= gfc_index_zero_node
;
10241 for (n
= 0 ; n
< rank
; n
++)
10245 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10246 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
10247 gfc_array_index_type
, zero_cond
,
10248 gfc_index_one_node
, lbound
);
10249 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
10251 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10252 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10253 gfc_array_index_type
, tmp
, lbound
);
10254 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
10255 gfc_rank_cst
[n
], lbound
);
10256 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
10257 gfc_rank_cst
[n
], tmp
);
10259 /* Set stride and accumulate the offset. */
10260 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
10261 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
10262 gfc_rank_cst
[n
], tmp
);
10263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10264 gfc_array_index_type
, lbound
, tmp
);
10265 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10266 gfc_array_index_type
, offset
, tmp
);
10267 offset
= gfc_evaluate_now (offset
, &se
->post
);
10270 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10275 /* Try to translate array(:) = func (...), where func is a transformational
10276 array function, without using a temporary. Returns NULL if this isn't the
10280 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10284 gfc_component
*comp
= NULL
;
10287 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10290 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10292 comp
= gfc_get_proc_ptr_comp (expr2
);
10294 if (!(expr2
->value
.function
.isym
10295 || (comp
&& comp
->attr
.dimension
)
10296 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10297 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10300 gfc_init_se (&se
, NULL
);
10301 gfc_start_block (&se
.pre
);
10302 se
.want_pointer
= 1;
10304 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10306 if (expr1
->ts
.type
== BT_DERIVED
10307 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10310 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10312 gfc_add_expr_to_block (&se
.pre
, tmp
);
10315 se
.direct_byref
= 1;
10316 se
.ss
= gfc_walk_expr (expr2
);
10317 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10319 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10320 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10321 Clearly, this cannot be done for an allocatable function result, since
10322 the shape of the result is unknown and, in any case, the function must
10323 correctly take care of the reallocation internally. For intrinsic
10324 calls, the array data is freed and the library takes care of allocation.
10325 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10327 if (flag_realloc_lhs
10328 && gfc_is_reallocatable_lhs (expr1
)
10329 && !gfc_expr_attr (expr1
).codimension
10330 && !gfc_is_coindexed (expr1
)
10331 && !(expr2
->value
.function
.esym
10332 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10334 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10336 if (!expr2
->value
.function
.isym
)
10338 ss
= gfc_walk_expr (expr1
);
10339 gcc_assert (ss
!= gfc_ss_terminator
);
10341 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10342 ss
->is_alloc_lhs
= 1;
10345 fcncall_realloc_result (&se
, expr1
->rank
);
10348 gfc_conv_function_expr (&se
, expr2
);
10349 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10352 gfc_cleanup_loop (&loop
);
10354 gfc_free_ss_chain (se
.ss
);
10356 return gfc_finish_block (&se
.pre
);
10360 /* Try to efficiently translate array(:) = 0. Return NULL if this
10364 gfc_trans_zero_assign (gfc_expr
* expr
)
10366 tree dest
, len
, type
;
10370 sym
= expr
->symtree
->n
.sym
;
10371 dest
= gfc_get_symbol_decl (sym
);
10373 type
= TREE_TYPE (dest
);
10374 if (POINTER_TYPE_P (type
))
10375 type
= TREE_TYPE (type
);
10376 if (!GFC_ARRAY_TYPE_P (type
))
10379 /* Determine the length of the array. */
10380 len
= GFC_TYPE_ARRAY_SIZE (type
);
10381 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10384 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10385 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10386 fold_convert (gfc_array_index_type
, tmp
));
10388 /* If we are zeroing a local array avoid taking its address by emitting
10390 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10391 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10392 dest
, build_constructor (TREE_TYPE (dest
),
10395 /* Convert arguments to the correct types. */
10396 dest
= fold_convert (pvoid_type_node
, dest
);
10397 len
= fold_convert (size_type_node
, len
);
10399 /* Construct call to __builtin_memset. */
10400 tmp
= build_call_expr_loc (input_location
,
10401 builtin_decl_explicit (BUILT_IN_MEMSET
),
10402 3, dest
, integer_zero_node
, len
);
10403 return fold_convert (void_type_node
, tmp
);
10407 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10408 that constructs the call to __builtin_memcpy. */
10411 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10415 /* Convert arguments to the correct types. */
10416 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10417 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10419 dst
= fold_convert (pvoid_type_node
, dst
);
10421 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10422 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10424 src
= fold_convert (pvoid_type_node
, src
);
10426 len
= fold_convert (size_type_node
, len
);
10428 /* Construct call to __builtin_memcpy. */
10429 tmp
= build_call_expr_loc (input_location
,
10430 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10432 return fold_convert (void_type_node
, tmp
);
10436 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10437 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10438 source/rhs, both are gfc_full_array_ref_p which have been checked for
10442 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10444 tree dst
, dlen
, dtype
;
10445 tree src
, slen
, stype
;
10448 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10449 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10451 dtype
= TREE_TYPE (dst
);
10452 if (POINTER_TYPE_P (dtype
))
10453 dtype
= TREE_TYPE (dtype
);
10454 stype
= TREE_TYPE (src
);
10455 if (POINTER_TYPE_P (stype
))
10456 stype
= TREE_TYPE (stype
);
10458 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10461 /* Determine the lengths of the arrays. */
10462 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10463 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10465 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10466 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10467 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10469 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10470 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10472 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10473 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10474 slen
, fold_convert (gfc_array_index_type
, tmp
));
10476 /* Sanity check that they are the same. This should always be
10477 the case, as we should already have checked for conformance. */
10478 if (!tree_int_cst_equal (slen
, dlen
))
10481 return gfc_build_memcpy_call (dst
, src
, dlen
);
10485 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10486 this can't be done. EXPR1 is the destination/lhs for which
10487 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10490 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10492 unsigned HOST_WIDE_INT nelem
;
10498 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
10502 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10503 dtype
= TREE_TYPE (dst
);
10504 if (POINTER_TYPE_P (dtype
))
10505 dtype
= TREE_TYPE (dtype
);
10506 if (!GFC_ARRAY_TYPE_P (dtype
))
10509 /* Determine the lengths of the array. */
10510 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
10511 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10514 /* Confirm that the constructor is the same size. */
10515 if (compare_tree_int (len
, nelem
) != 0)
10518 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10519 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10520 fold_convert (gfc_array_index_type
, tmp
));
10522 stype
= gfc_typenode_for_spec (&expr2
->ts
);
10523 src
= gfc_build_constant_array_constructor (expr2
, stype
);
10525 return gfc_build_memcpy_call (dst
, src
, len
);
10529 /* Tells whether the expression is to be treated as a variable reference. */
10532 gfc_expr_is_variable (gfc_expr
*expr
)
10535 gfc_component
*comp
;
10536 gfc_symbol
*func_ifc
;
10538 if (expr
->expr_type
== EXPR_VARIABLE
)
10541 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
10544 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
10545 return gfc_expr_is_variable (arg
);
10548 /* A data-pointer-returning function should be considered as a variable
10550 if (expr
->expr_type
== EXPR_FUNCTION
10551 && expr
->ref
== NULL
)
10553 if (expr
->value
.function
.isym
!= NULL
)
10556 if (expr
->value
.function
.esym
!= NULL
)
10558 func_ifc
= expr
->value
.function
.esym
;
10563 gcc_assert (expr
->symtree
);
10564 func_ifc
= expr
->symtree
->n
.sym
;
10568 gcc_unreachable ();
10571 comp
= gfc_get_proc_ptr_comp (expr
);
10572 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
10575 func_ifc
= comp
->ts
.interface
;
10579 if (expr
->expr_type
== EXPR_COMPCALL
)
10581 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
10582 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
10589 gcc_assert (func_ifc
->attr
.function
10590 && func_ifc
->result
!= NULL
);
10591 return func_ifc
->result
->attr
.pointer
;
10595 /* Is the lhs OK for automatic reallocation? */
10598 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
10602 /* An allocatable variable with no reference. */
10603 if (expr
->symtree
->n
.sym
->attr
.allocatable
10607 /* All that can be left are allocatable components. However, we do
10608 not check for allocatable components here because the expression
10609 could be an allocatable component of a pointer component. */
10610 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10611 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
10614 /* Find an allocatable component ref last. */
10615 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10616 if (ref
->type
== REF_COMPONENT
10618 && ref
->u
.c
.component
->attr
.allocatable
)
10625 /* Allocate or reallocate scalar lhs, as necessary. */
10628 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
10629 tree string_length
,
10637 tree size_in_bytes
;
10643 if (!expr1
|| expr1
->rank
)
10646 if (!expr2
|| expr2
->rank
)
10649 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10650 if (ref
->type
== REF_SUBSTRING
)
10653 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
10655 /* Since this is a scalar lhs, we can afford to do this. That is,
10656 there is no risk of side effects being repeated. */
10657 gfc_init_se (&lse
, NULL
);
10658 lse
.want_pointer
= 1;
10659 gfc_conv_expr (&lse
, expr1
);
10661 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10662 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10664 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10665 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
10666 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10668 tmp
= build3_v (COND_EXPR
, cond
,
10669 build1_v (GOTO_EXPR
, jump_label1
),
10670 build_empty_stmt (input_location
));
10671 gfc_add_expr_to_block (block
, tmp
);
10673 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10675 /* Use the rhs string length and the lhs element size. */
10676 size
= string_length
;
10677 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10678 tmp
= TYPE_SIZE_UNIT (tmp
);
10679 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10680 TREE_TYPE (tmp
), tmp
,
10681 fold_convert (TREE_TYPE (tmp
), size
));
10685 /* Otherwise use the length in bytes of the rhs. */
10686 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10687 size_in_bytes
= size
;
10690 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10691 size_in_bytes
, size_one_node
);
10693 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10695 tree caf_decl
, token
;
10697 symbol_attribute attr
;
10699 gfc_clear_attr (&attr
);
10700 gfc_init_se (&caf_se
, NULL
);
10702 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10703 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10705 gfc_add_block_to_block (block
, &caf_se
.pre
);
10706 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10707 gfc_build_addr_expr (NULL_TREE
, token
),
10708 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10711 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10713 tmp
= build_call_expr_loc (input_location
,
10714 builtin_decl_explicit (BUILT_IN_CALLOC
),
10715 2, build_one_cst (size_type_node
),
10717 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10718 gfc_add_modify (block
, lse
.expr
, tmp
);
10722 tmp
= build_call_expr_loc (input_location
,
10723 builtin_decl_explicit (BUILT_IN_MALLOC
),
10725 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10726 gfc_add_modify (block
, lse
.expr
, tmp
);
10729 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10731 /* Deferred characters need checking for lhs and rhs string
10732 length. Other deferred parameter variables will have to
10734 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10735 gfc_add_expr_to_block (block
, tmp
);
10737 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10738 gfc_add_expr_to_block (block
, tmp
);
10740 /* For a deferred length character, reallocate if lengths of lhs and
10741 rhs are different. */
10742 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10744 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10746 fold_convert (TREE_TYPE (lse
.string_length
),
10748 /* Jump past the realloc if the lengths are the same. */
10749 tmp
= build3_v (COND_EXPR
, cond
,
10750 build1_v (GOTO_EXPR
, jump_label2
),
10751 build_empty_stmt (input_location
));
10752 gfc_add_expr_to_block (block
, tmp
);
10753 tmp
= build_call_expr_loc (input_location
,
10754 builtin_decl_explicit (BUILT_IN_REALLOC
),
10755 2, fold_convert (pvoid_type_node
, lse
.expr
),
10757 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10758 gfc_add_modify (block
, lse
.expr
, tmp
);
10759 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10760 gfc_add_expr_to_block (block
, tmp
);
10762 /* Update the lhs character length. */
10763 size
= string_length
;
10764 gfc_add_modify (block
, lse
.string_length
,
10765 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10769 /* Check for assignments of the type
10773 to make sure we do not check for reallocation unneccessarily. */
10777 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10779 gfc_actual_arglist
*a
;
10782 switch (expr2
->expr_type
)
10784 case EXPR_VARIABLE
:
10785 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10787 case EXPR_FUNCTION
:
10788 if (expr2
->value
.function
.esym
10789 && expr2
->value
.function
.esym
->attr
.elemental
)
10791 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10794 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10799 else if (expr2
->value
.function
.isym
10800 && expr2
->value
.function
.isym
->elemental
)
10802 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10805 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10814 switch (expr2
->value
.op
.op
)
10816 case INTRINSIC_NOT
:
10817 case INTRINSIC_UPLUS
:
10818 case INTRINSIC_UMINUS
:
10819 case INTRINSIC_PARENTHESES
:
10820 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10822 case INTRINSIC_PLUS
:
10823 case INTRINSIC_MINUS
:
10824 case INTRINSIC_TIMES
:
10825 case INTRINSIC_DIVIDE
:
10826 case INTRINSIC_POWER
:
10827 case INTRINSIC_AND
:
10829 case INTRINSIC_EQV
:
10830 case INTRINSIC_NEQV
:
10837 case INTRINSIC_EQ_OS
:
10838 case INTRINSIC_NE_OS
:
10839 case INTRINSIC_GT_OS
:
10840 case INTRINSIC_GE_OS
:
10841 case INTRINSIC_LT_OS
:
10842 case INTRINSIC_LE_OS
:
10844 e1
= expr2
->value
.op
.op1
;
10845 e2
= expr2
->value
.op
.op2
;
10847 if (e1
->rank
== 0 && e2
->rank
> 0)
10848 return is_runtime_conformable (expr1
, e2
);
10849 else if (e1
->rank
> 0 && e2
->rank
== 0)
10850 return is_runtime_conformable (expr1
, e1
);
10851 else if (e1
->rank
> 0 && e2
->rank
> 0)
10852 return is_runtime_conformable (expr1
, e1
)
10853 && is_runtime_conformable (expr1
, e2
);
10871 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10872 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10873 bool class_realloc
)
10875 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
, old_vptr
;
10876 vec
<tree
, va_gc
> *args
= NULL
;
10878 /* Store the old vptr so that dynamic types can be compared for
10879 reallocation to occur or not. */
10883 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
10884 tmp
= gfc_get_class_from_expr (tmp
);
10887 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10890 /* Generate (re)allocation of the lhs. */
10893 stmtblock_t alloc
, re_alloc
;
10894 tree class_han
, re
, size
;
10896 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
10897 old_vptr
= gfc_evaluate_now (gfc_class_vptr_get (tmp
), block
);
10899 old_vptr
= build_int_cst (TREE_TYPE (vptr
), 0);
10901 size
= gfc_vptr_size_get (vptr
);
10902 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10903 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10905 /* Allocate block. */
10906 gfc_init_block (&alloc
);
10907 gfc_allocate_using_malloc (&alloc
, class_han
, size
, NULL_TREE
);
10909 /* Reallocate if dynamic types are different. */
10910 gfc_init_block (&re_alloc
);
10911 re
= build_call_expr_loc (input_location
,
10912 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10913 fold_convert (pvoid_type_node
, class_han
),
10915 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10916 logical_type_node
, vptr
, old_vptr
);
10917 re
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10918 tmp
, re
, build_empty_stmt (input_location
));
10919 gfc_add_expr_to_block (&re_alloc
, re
);
10921 /* Allocate if _data is NULL, reallocate otherwise. */
10922 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10923 logical_type_node
, class_han
,
10924 build_int_cst (prvoid_type_node
, 0));
10925 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10927 PRED_FORTRAN_FAIL_ALLOC
),
10928 gfc_finish_block (&alloc
),
10929 gfc_finish_block (&re_alloc
));
10930 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10933 fcn
= gfc_vptr_copy_get (vptr
);
10935 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10936 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10939 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10940 || INDIRECT_REF_P (tmp
)
10941 || (rhs
->ts
.type
== BT_DERIVED
10942 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10943 && !rhs
->ts
.u
.derived
->attr
.pointer
10944 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10945 || (UNLIMITED_POLY (rhs
)
10946 && !CLASS_DATA (rhs
)->attr
.pointer
10947 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10948 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10950 vec_safe_push (args
, tmp
);
10951 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10952 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10953 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10954 || INDIRECT_REF_P (tmp
)
10955 || (lhs
->ts
.type
== BT_DERIVED
10956 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10957 && !lhs
->ts
.u
.derived
->attr
.pointer
10958 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10959 || (UNLIMITED_POLY (lhs
)
10960 && !CLASS_DATA (lhs
)->attr
.pointer
10961 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10962 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10964 vec_safe_push (args
, tmp
);
10966 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10968 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10971 vec_safe_push (args
, from_len
);
10972 vec_safe_push (args
, to_len
);
10973 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10975 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10976 logical_type_node
, from_len
,
10977 build_zero_cst (TREE_TYPE (from_len
)));
10978 return fold_build3_loc (input_location
, COND_EXPR
,
10979 void_type_node
, tmp
,
10987 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10988 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10989 stmtblock_t tblock
;
10990 gfc_init_block (&tblock
);
10991 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10992 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10993 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10994 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10995 /* When coming from a ptr_copy lhs and rhs are swapped. */
10996 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10997 fold_convert (TREE_TYPE (rhst
), tmp
));
10998 return gfc_finish_block (&tblock
);
11002 /* Subroutine of gfc_trans_assignment that actually scalarizes the
11003 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11004 init_flag indicates initialization expressions and dealloc that no
11005 deallocate prior assignment is needed (if in doubt, set true).
11006 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11007 routine instead of a pointer assignment. Alias resolution is only done,
11008 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11009 where it is known, that newly allocated memory on the lhs can never be
11010 an alias of the rhs. */
11013 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11014 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11019 gfc_ss
*lss_section
;
11026 bool scalar_to_array
;
11027 tree string_length
;
11029 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
11030 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
11031 bool is_poly_assign
;
11034 /* Assignment of the form lhs = rhs. */
11035 gfc_start_block (&block
);
11037 gfc_init_se (&lse
, NULL
);
11038 gfc_init_se (&rse
, NULL
);
11040 /* Walk the lhs. */
11041 lss
= gfc_walk_expr (expr1
);
11042 if (gfc_is_reallocatable_lhs (expr1
))
11044 lss
->no_bounds_check
= 1;
11045 if (!(expr2
->expr_type
== EXPR_FUNCTION
11046 && expr2
->value
.function
.isym
!= NULL
11047 && !(expr2
->value
.function
.isym
->elemental
11048 || expr2
->value
.function
.isym
->conversion
)))
11049 lss
->is_alloc_lhs
= 1;
11052 lss
->no_bounds_check
= expr1
->no_bounds_check
;
11056 if ((expr1
->ts
.type
== BT_DERIVED
)
11057 && (gfc_is_class_array_function (expr2
)
11058 || gfc_is_alloc_class_scalar_function (expr2
)))
11059 expr2
->must_finalize
= 1;
11061 /* Checking whether a class assignment is desired is quite complicated and
11062 needed at two locations, so do it once only before the information is
11064 lhs_attr
= gfc_expr_attr (expr1
);
11065 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
11066 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
11067 && (expr1
->ts
.type
== BT_CLASS
11068 || gfc_is_class_array_ref (expr1
, NULL
)
11069 || gfc_is_class_scalar_expr (expr1
)
11070 || gfc_is_class_array_ref (expr2
, NULL
)
11071 || gfc_is_class_scalar_expr (expr2
));
11073 realloc_flag
= flag_realloc_lhs
11074 && gfc_is_reallocatable_lhs (expr1
)
11076 && !is_runtime_conformable (expr1
, expr2
);
11078 /* Only analyze the expressions for coarray properties, when in coarray-lib
11080 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11082 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
11083 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
11086 if (lss
!= gfc_ss_terminator
)
11088 /* The assignment needs scalarization. */
11091 /* Find a non-scalar SS from the lhs. */
11092 while (lss_section
!= gfc_ss_terminator
11093 && lss_section
->info
->type
!= GFC_SS_SECTION
)
11094 lss_section
= lss_section
->next
;
11096 gcc_assert (lss_section
!= gfc_ss_terminator
);
11098 /* Initialize the scalarizer. */
11099 gfc_init_loopinfo (&loop
);
11101 /* Walk the rhs. */
11102 rss
= gfc_walk_expr (expr2
);
11103 if (rss
== gfc_ss_terminator
)
11104 /* The rhs is scalar. Add a ss for the expression. */
11105 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
11106 /* When doing a class assign, then the handle to the rhs needs to be a
11107 pointer to allow for polymorphism. */
11108 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
11109 rss
->info
->type
= GFC_SS_REFERENCE
;
11111 rss
->no_bounds_check
= expr2
->no_bounds_check
;
11112 /* Associate the SS with the loop. */
11113 gfc_add_ss_to_loop (&loop
, lss
);
11114 gfc_add_ss_to_loop (&loop
, rss
);
11116 /* Calculate the bounds of the scalarization. */
11117 gfc_conv_ss_startstride (&loop
);
11118 /* Enable loop reversal. */
11119 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
11120 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
11121 /* Resolve any data dependencies in the statement. */
11123 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
11124 /* Setup the scalarizing loops. */
11125 gfc_conv_loop_setup (&loop
, &expr2
->where
);
11127 /* Setup the gfc_se structures. */
11128 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11129 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11132 gfc_mark_ss_chain_used (rss
, 1);
11133 if (loop
.temp_ss
== NULL
)
11136 gfc_mark_ss_chain_used (lss
, 1);
11140 lse
.ss
= loop
.temp_ss
;
11141 gfc_mark_ss_chain_used (lss
, 3);
11142 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
11145 /* Allow the scalarizer to workshare array assignments. */
11146 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
11147 == OMPWS_WORKSHARE_FLAG
11148 && loop
.temp_ss
== NULL
)
11150 maybe_workshare
= true;
11151 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
11154 /* Start the scalarized loop body. */
11155 gfc_start_scalarized_body (&loop
, &body
);
11158 gfc_init_block (&body
);
11160 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
11162 /* Translate the expression. */
11163 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
11164 && lhs_caf_attr
.codimension
;
11165 gfc_conv_expr (&rse
, expr2
);
11167 /* Deal with the case of a scalar class function assigned to a derived type. */
11168 if (gfc_is_alloc_class_scalar_function (expr2
)
11169 && expr1
->ts
.type
== BT_DERIVED
)
11171 rse
.expr
= gfc_class_data_get (rse
.expr
);
11172 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
11175 /* Stabilize a string length for temporaries. */
11176 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
11177 && !(VAR_P (rse
.string_length
)
11178 || TREE_CODE (rse
.string_length
) == PARM_DECL
11179 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
11180 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
11181 else if (expr2
->ts
.type
== BT_CHARACTER
)
11183 if (expr1
->ts
.deferred
11184 && gfc_expr_attr (expr1
).allocatable
11185 && gfc_check_dependency (expr1
, expr2
, true))
11186 rse
.string_length
=
11187 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
11188 string_length
= rse
.string_length
;
11191 string_length
= NULL_TREE
;
11195 gfc_conv_tmp_array_ref (&lse
);
11196 if (expr2
->ts
.type
== BT_CHARACTER
)
11197 lse
.string_length
= string_length
;
11201 gfc_conv_expr (&lse
, expr1
);
11202 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
11204 && gfc_expr_attr (expr1
).allocatable
11211 tmp
= INDIRECT_REF_P (lse
.expr
)
11212 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
11214 /* We should only get array references here. */
11215 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
11216 || TREE_CODE (tmp
) == ARRAY_REF
);
11218 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
11219 or the array itself(ARRAY_REF). */
11220 tmp
= TREE_OPERAND (tmp
, 0);
11222 /* Provide the address of the array. */
11223 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
11224 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11226 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
11227 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
11228 msg
= _("Assignment of scalar to unallocated array");
11229 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
11230 &expr1
->where
, msg
);
11233 /* Deallocate the lhs parameterized components if required. */
11234 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
11235 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
11237 if (expr1
->ts
.type
== BT_DERIVED
11238 && expr1
->ts
.u
.derived
11239 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
11241 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
11243 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11245 else if (expr1
->ts
.type
== BT_CLASS
11246 && CLASS_DATA (expr1
)->ts
.u
.derived
11247 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
11249 tmp
= gfc_class_data_get (lse
.expr
);
11250 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
11252 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11257 /* Assignments of scalar derived types with allocatable components
11258 to arrays must be done with a deep copy and the rhs temporary
11259 must have its components deallocated afterwards. */
11260 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
11261 && expr2
->ts
.u
.derived
->attr
.alloc_comp
11262 && !gfc_expr_is_variable (expr2
)
11263 && expr1
->rank
&& !expr2
->rank
);
11264 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
11266 && expr1
->ts
.u
.derived
->attr
.alloc_comp
11267 && gfc_is_alloc_class_scalar_function (expr2
));
11268 if (scalar_to_array
&& dealloc
)
11270 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
11271 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
11274 /* When assigning a character function result to a deferred-length variable,
11275 the function call must happen before the (re)allocation of the lhs -
11276 otherwise the character length of the result is not known.
11277 NOTE 1: This relies on having the exact dependence of the length type
11278 parameter available to the caller; gfortran saves it in the .mod files.
11279 NOTE 2: Vector array references generate an index temporary that must
11280 not go outside the loop. Otherwise, variables should not generate
11282 NOTE 3: The concatenation operation generates a temporary pointer,
11283 whose allocation must go to the innermost loop.
11284 NOTE 4: Elemental functions may generate a temporary, too. */
11285 if (flag_realloc_lhs
11286 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
11287 && !(lss
!= gfc_ss_terminator
11288 && rss
!= gfc_ss_terminator
11289 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
11290 || (expr2
->expr_type
== EXPR_FUNCTION
11291 && expr2
->value
.function
.esym
!= NULL
11292 && expr2
->value
.function
.esym
->attr
.elemental
)
11293 || (expr2
->expr_type
== EXPR_FUNCTION
11294 && expr2
->value
.function
.isym
!= NULL
11295 && expr2
->value
.function
.isym
->elemental
)
11296 || (expr2
->expr_type
== EXPR_OP
11297 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
11298 gfc_add_block_to_block (&block
, &rse
.pre
);
11300 /* Nullify the allocatable components corresponding to those of the lhs
11301 derived type, so that the finalization of the function result does not
11302 affect the lhs of the assignment. Prepend is used to ensure that the
11303 nullification occurs before the call to the finalizer. In the case of
11304 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11305 as part of the deep copy. */
11306 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11307 && (gfc_is_class_array_function (expr2
)
11308 || gfc_is_alloc_class_scalar_function (expr2
)))
11310 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11311 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11312 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11313 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11318 if (is_poly_assign
)
11320 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11321 use_vptr_copy
|| (lhs_attr
.allocatable
11322 && !lhs_attr
.dimension
),
11323 !realloc_flag
&& flag_realloc_lhs
11324 && !lhs_attr
.pointer
);
11325 if (expr2
->expr_type
== EXPR_FUNCTION
11326 && expr2
->ts
.type
== BT_DERIVED
11327 && expr2
->ts
.u
.derived
->attr
.alloc_comp
)
11329 tree tmp2
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
,
11330 rse
.expr
, expr2
->rank
);
11331 if (lss
== gfc_ss_terminator
)
11332 gfc_add_expr_to_block (&rse
.post
, tmp2
);
11334 gfc_add_expr_to_block (&loop
.post
, tmp2
);
11337 else if (flag_coarray
== GFC_FCOARRAY_LIB
11338 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11339 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11340 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11342 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11343 allocatable component, because those need to be accessed via the
11344 caf-runtime. No need to check for coindexes here, because resolve
11345 has rewritten those already. */
11347 gfc_actual_arglist a1
, a2
;
11348 /* Clear the structures to prevent accessing garbage. */
11349 memset (&code
, '\0', sizeof (gfc_code
));
11350 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11351 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11356 code
.ext
.actual
= &a1
;
11357 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11358 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11360 else if (!is_poly_assign
&& expr2
->must_finalize
11361 && expr1
->ts
.type
== BT_CLASS
11362 && expr2
->ts
.type
== BT_CLASS
)
11364 /* This case comes about when the scalarizer provides array element
11365 references. Use the vptr copy function, since this does a deep
11366 copy of allocatable components, without which the finalizer call
11367 will deallocate the components. */
11368 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11369 if (tmp
!= NULL_TREE
)
11371 tree fcn
= gfc_vptr_copy_get (tmp
);
11372 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11373 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11374 tmp
= build_call_expr_loc (input_location
,
11376 gfc_build_addr_expr (NULL
, rse
.expr
),
11377 gfc_build_addr_expr (NULL
, lse
.expr
));
11381 /* If nothing else works, do it the old fashioned way! */
11382 if (tmp
== NULL_TREE
)
11383 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11384 gfc_expr_is_variable (expr2
)
11386 || expr2
->expr_type
== EXPR_ARRAY
,
11387 !(l_is_temp
|| init_flag
) && dealloc
,
11388 expr1
->symtree
->n
.sym
->attr
.codimension
);
11390 /* Add the pre blocks to the body. */
11391 gfc_add_block_to_block (&body
, &rse
.pre
);
11392 gfc_add_block_to_block (&body
, &lse
.pre
);
11393 gfc_add_expr_to_block (&body
, tmp
);
11394 /* Add the post blocks to the body. */
11395 gfc_add_block_to_block (&body
, &rse
.post
);
11396 gfc_add_block_to_block (&body
, &lse
.post
);
11398 if (lss
== gfc_ss_terminator
)
11400 /* F2003: Add the code for reallocation on assignment. */
11401 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11402 && !is_poly_assign
)
11403 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11406 /* Use the scalar assignment as is. */
11407 gfc_add_block_to_block (&block
, &body
);
11411 gcc_assert (lse
.ss
== gfc_ss_terminator
11412 && rse
.ss
== gfc_ss_terminator
);
11416 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11418 /* We need to copy the temporary to the actual lhs. */
11419 gfc_init_se (&lse
, NULL
);
11420 gfc_init_se (&rse
, NULL
);
11421 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11422 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11424 rse
.ss
= loop
.temp_ss
;
11427 gfc_conv_tmp_array_ref (&rse
);
11428 gfc_conv_expr (&lse
, expr1
);
11430 gcc_assert (lse
.ss
== gfc_ss_terminator
11431 && rse
.ss
== gfc_ss_terminator
);
11433 if (expr2
->ts
.type
== BT_CHARACTER
)
11434 rse
.string_length
= string_length
;
11436 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11438 gfc_add_expr_to_block (&body
, tmp
);
11441 /* F2003: Allocate or reallocate lhs of allocatable array. */
11444 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11445 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11446 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11447 if (tmp
!= NULL_TREE
)
11448 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11451 if (maybe_workshare
)
11452 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11454 /* Generate the copying loops. */
11455 gfc_trans_scalarizing_loops (&loop
, &body
);
11457 /* Wrap the whole thing up. */
11458 gfc_add_block_to_block (&block
, &loop
.pre
);
11459 gfc_add_block_to_block (&block
, &loop
.post
);
11461 gfc_cleanup_loop (&loop
);
11464 return gfc_finish_block (&block
);
11468 /* Check whether EXPR is a copyable array. */
11471 copyable_array_p (gfc_expr
* expr
)
11473 if (expr
->expr_type
!= EXPR_VARIABLE
)
11476 /* First check it's an array. */
11477 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11480 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11483 /* Next check that it's of a simple enough type. */
11484 switch (expr
->ts
.type
)
11496 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
11505 /* Translate an assignment. */
11508 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11509 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11513 /* Special case a single function returning an array. */
11514 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
11516 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
11521 /* Special case assigning an array to zero. */
11522 if (copyable_array_p (expr1
)
11523 && is_zero_initializer_p (expr2
))
11525 tmp
= gfc_trans_zero_assign (expr1
);
11530 /* Special case copying one array to another. */
11531 if (copyable_array_p (expr1
)
11532 && copyable_array_p (expr2
)
11533 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
11534 && !gfc_check_dependency (expr1
, expr2
, 0))
11536 tmp
= gfc_trans_array_copy (expr1
, expr2
);
11541 /* Special case initializing an array from a constant array constructor. */
11542 if (copyable_array_p (expr1
)
11543 && expr2
->expr_type
== EXPR_ARRAY
11544 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
11546 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
11551 if (UNLIMITED_POLY (expr1
) && expr1
->rank
)
11552 use_vptr_copy
= true;
11554 /* Fallback to the scalarizer to generate explicit loops. */
11555 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
11556 use_vptr_copy
, may_alias
);
11560 gfc_trans_init_assign (gfc_code
* code
)
11562 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
11566 gfc_trans_assign (gfc_code
* code
)
11568 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);