1 /* Expression translation
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 tree desc
, type
, etype
;
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 etype
= TREE_TYPE (scalar
);
73 desc
= gfc_create_var (type
, "desc");
74 DECL_ARTIFICIAL (desc
) = 1;
76 if (CONSTANT_CLASS_P (scalar
))
79 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
80 gfc_add_modify (&se
->pre
, tmp
, scalar
);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
84 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
85 else if (TREE_TYPE (etype
) && TREE_CODE (TREE_TYPE (etype
)) == ARRAY_TYPE
)
86 etype
= TREE_TYPE (etype
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype_rank_type (0, etype
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
107 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
108 bool is_coarray
= sym
->attr
.codimension
;
109 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
110 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
114 if (ref
->type
== REF_COMPONENT
115 && (ref
->u
.c
.component
->attr
.allocatable
116 || ref
->u
.c
.component
->attr
.pointer
)
117 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
122 if (last_caf_ref
== NULL
)
125 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
127 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
128 if (comp
== NULL_TREE
&& comp_ref
)
130 gfc_init_se (&se
, outerse
);
131 gfc_free_ref_list (last_caf_ref
->next
);
132 last_caf_ref
->next
= NULL
;
133 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
134 se
.want_pointer
= comp_ref
;
135 gfc_conv_expr (&se
, caf_expr
);
136 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
138 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
139 se
.expr
= TREE_OPERAND (se
.expr
, 0);
140 gfc_free_expr (caf_expr
);
143 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
146 caf
= gfc_conv_descriptor_token (se
.expr
);
147 return gfc_build_addr_expr (NULL_TREE
, caf
);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
172 vec
<constructor_elt
, va_gc
> *init
= NULL
;
174 field
= TYPE_FIELDS (TREE_TYPE (decl
));
175 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
178 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
179 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
181 return build_constructor (TREE_TYPE (decl
), init
);
186 gfc_class_data_get (tree decl
)
189 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
190 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
191 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
193 return fold_build3_loc (input_location
, COMPONENT_REF
,
194 TREE_TYPE (data
), decl
, data
,
200 gfc_class_vptr_get (tree decl
)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
207 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
208 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
209 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
210 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
212 return fold_build3_loc (input_location
, COMPONENT_REF
,
213 TREE_TYPE (vptr
), decl
, vptr
,
219 gfc_class_len_get (tree decl
)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
226 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
227 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
228 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
229 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
231 return fold_build3_loc (input_location
, COMPONENT_REF
,
232 TREE_TYPE (len
), decl
, len
,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl
)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
248 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
249 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
250 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
251 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
253 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
254 TREE_TYPE (len
), decl
, len
,
256 : build_zero_cst (gfc_charlen_type_node
);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr
, int fieldno
)
266 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
267 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
269 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
270 TREE_TYPE (field
), vptr
, field
,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl
, int fieldno
)
283 vptr
= gfc_class_vptr_get (decl
);
284 return vptr_field_get (vptr
, fieldno
);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
303 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
304 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
305 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
306 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
307 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl
)
317 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
318 /* Always return size as an array index type. */
319 size
= fold_convert (gfc_array_index_type
, size
);
325 gfc_vptr_size_get (tree vptr
)
328 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
329 /* Always return size as an array index type. */
330 size
= fold_convert (gfc_array_index_type
, size
);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
, bool is_mold
)
358 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
360 /* Find the last class reference. */
363 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
365 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
380 if (ref
->next
== NULL
)
384 /* Remove and store all subsequent references after the
388 tail
= class_ref
->next
;
389 class_ref
->next
= NULL
;
391 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
398 base_expr
= gfc_expr_to_initialize (e
);
400 base_expr
= gfc_copy_expr (e
);
402 /* Restore the original tail expression. */
405 gfc_free_ref_list (class_ref
->next
);
406 class_ref
->next
= tail
;
408 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
410 gfc_free_ref_list (e
->ref
);
417 /* Reset the vptr to the declared type, e.g. after deallocation. */
420 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
427 /* Evaluate the expression and obtain the vptr from it. */
428 gfc_init_se (&se
, NULL
);
430 gfc_conv_expr_descriptor (&se
, e
);
432 gfc_conv_expr (&se
, e
);
433 gfc_add_block_to_block (block
, &se
.pre
);
434 vptr
= gfc_get_vptr_from_expr (se
.expr
);
436 /* If a vptr is not found, we can do nothing more. */
437 if (vptr
== NULL_TREE
)
440 if (UNLIMITED_POLY (e
))
441 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
444 /* Return the vptr to the address of the declared type. */
445 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
446 vtable
= vtab
->backend_decl
;
447 if (vtable
== NULL_TREE
)
448 vtable
= gfc_get_symbol_decl (vtab
);
449 vtable
= gfc_build_addr_expr (NULL
, vtable
);
450 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
451 gfc_add_modify (block
, vptr
, vtable
);
456 /* Reset the len for unlimited polymorphic objects. */
459 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
463 e
= gfc_find_and_cut_at_last_class_ref (expr
);
466 gfc_add_len_component (e
);
467 gfc_init_se (&se_len
, NULL
);
468 gfc_conv_expr (&se_len
, e
);
469 gfc_add_modify (block
, se_len
.expr
,
470 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
475 /* Obtain the last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_class_from_expr (tree expr
)
484 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
486 type
= TREE_TYPE (tmp
);
489 if (GFC_CLASS_TYPE_P (type
))
491 if (type
!= TYPE_CANONICAL (type
))
492 type
= TYPE_CANONICAL (type
);
496 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
500 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
501 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
510 /* Obtain the vptr of the last class reference in an expression.
511 Return NULL_TREE if no class reference is found. */
514 gfc_get_vptr_from_expr (tree expr
)
518 tmp
= gfc_get_class_from_expr (expr
);
520 if (tmp
!= NULL_TREE
)
521 return gfc_class_vptr_get (tmp
);
528 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
531 tree tmp
, tmp2
, type
;
533 gfc_conv_descriptor_data_set (block
, lhs_desc
,
534 gfc_conv_descriptor_data_get (rhs_desc
));
535 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
536 gfc_conv_descriptor_offset_get (rhs_desc
));
538 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
539 gfc_conv_descriptor_dtype (rhs_desc
));
541 /* Assign the dimension as range-ref. */
542 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
543 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
545 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
546 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
547 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
548 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
549 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
550 gfc_add_modify (block
, tmp
, tmp2
);
554 /* Takes a derived type expression and returns the address of a temporary
555 class object of the 'declared' type. If vptr is not NULL, this is
556 used for the temporary class object.
557 optional_alloc_ptr is false when the dummy is neither allocatable
558 nor a pointer; that's only relevant for the optional handling. */
560 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
561 gfc_typespec class_ts
, tree vptr
, bool optional
,
562 bool optional_alloc_ptr
)
565 tree cond_optional
= NULL_TREE
;
572 /* The derived type needs to be converted to a temporary
574 tmp
= gfc_typenode_for_spec (&class_ts
);
575 var
= gfc_create_var (tmp
, "class");
578 ctree
= gfc_class_vptr_get (var
);
580 if (vptr
!= NULL_TREE
)
582 /* Use the dynamic vptr. */
587 /* In this case the vtab corresponds to the derived type and the
588 vptr must point to it. */
589 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
591 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
593 gfc_add_modify (&parmse
->pre
, ctree
,
594 fold_convert (TREE_TYPE (ctree
), tmp
));
596 /* Now set the data field. */
597 ctree
= gfc_class_data_get (var
);
600 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
602 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
604 /* If there is a ready made pointer to a derived type, use it
605 rather than evaluating the expression again. */
606 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
607 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
609 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
611 /* For an array reference in an elemental procedure call we need
612 to retain the ss to provide the scalarized array reference. */
613 gfc_conv_expr_reference (parmse
, e
);
614 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
616 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
618 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
619 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
623 ss
= gfc_walk_expr (e
);
624 if (ss
== gfc_ss_terminator
)
627 gfc_conv_expr_reference (parmse
, e
);
629 /* Scalar to an assumed-rank array. */
630 if (class_ts
.u
.derived
->components
->as
)
633 type
= get_scalar_to_descriptor_type (parmse
->expr
,
635 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
636 gfc_get_dtype (type
));
638 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
639 TREE_TYPE (parmse
->expr
),
640 cond_optional
, parmse
->expr
,
641 fold_convert (TREE_TYPE (parmse
->expr
),
643 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
647 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
649 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
651 fold_convert (TREE_TYPE (tmp
),
653 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
659 gfc_init_block (&block
);
663 parmse
->use_offset
= 1;
664 gfc_conv_expr_descriptor (parmse
, e
);
666 /* Detect any array references with vector subscripts. */
667 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
668 if (ref
->type
== REF_ARRAY
669 && ref
->u
.ar
.type
!= AR_ELEMENT
670 && ref
->u
.ar
.type
!= AR_FULL
)
672 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
673 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
675 if (dim
< ref
->u
.ar
.dimen
)
679 /* Array references with vector subscripts and non-variable expressions
680 need be converted to a one-based descriptor. */
681 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
683 for (dim
= 0; dim
< e
->rank
; ++dim
)
684 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
688 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
690 gcc_assert (class_ts
.u
.derived
->components
->as
->type
692 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
696 if (gfc_expr_attr (e
).codimension
)
697 parmse
->expr
= fold_build1_loc (input_location
,
701 gfc_add_modify (&block
, ctree
, parmse
->expr
);
706 tmp
= gfc_finish_block (&block
);
708 gfc_init_block (&block
);
709 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
711 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
712 gfc_finish_block (&block
));
713 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
716 gfc_add_block_to_block (&parmse
->pre
, &block
);
720 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
721 && class_ts
.u
.derived
->components
->ts
.u
.derived
722 ->attr
.unlimited_polymorphic
)
724 /* Take care about initializing the _len component correctly. */
725 ctree
= gfc_class_len_get (var
);
726 if (UNLIMITED_POLY (e
))
731 len
= gfc_copy_expr (e
);
732 gfc_add_len_component (len
);
733 gfc_init_se (&se
, NULL
);
734 gfc_conv_expr (&se
, len
);
736 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
737 cond_optional
, se
.expr
,
738 fold_convert (TREE_TYPE (se
.expr
),
744 tmp
= integer_zero_node
;
745 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
748 /* Pass the address of the class object. */
749 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
751 if (optional
&& optional_alloc_ptr
)
752 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
753 TREE_TYPE (parmse
->expr
),
754 cond_optional
, parmse
->expr
,
755 fold_convert (TREE_TYPE (parmse
->expr
),
760 /* Create a new class container, which is required as scalar coarrays
761 have an array descriptor while normal scalars haven't. Optionally,
762 NULL pointer checks are added if the argument is OPTIONAL. */
765 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
766 gfc_typespec class_ts
, bool optional
)
768 tree var
, ctree
, tmp
;
773 gfc_init_block (&block
);
776 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
778 if (ref
->type
== REF_COMPONENT
779 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
783 if (class_ref
== NULL
784 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
785 tmp
= e
->symtree
->n
.sym
->backend_decl
;
788 /* Remove everything after the last class reference, convert the
789 expression and then recover its tailend once more. */
791 ref
= class_ref
->next
;
792 class_ref
->next
= NULL
;
793 gfc_init_se (&tmpse
, NULL
);
794 gfc_conv_expr (&tmpse
, e
);
795 class_ref
->next
= ref
;
799 var
= gfc_typenode_for_spec (&class_ts
);
800 var
= gfc_create_var (var
, "class");
802 ctree
= gfc_class_vptr_get (var
);
803 gfc_add_modify (&block
, ctree
,
804 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
806 ctree
= gfc_class_data_get (var
);
807 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
808 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
810 /* Pass the address of the class object. */
811 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
815 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
818 tmp
= gfc_finish_block (&block
);
820 gfc_init_block (&block
);
821 tmp2
= gfc_class_data_get (var
);
822 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
824 tmp2
= gfc_finish_block (&block
);
826 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
828 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
831 gfc_add_block_to_block (&parmse
->pre
, &block
);
835 /* Takes an intrinsic type expression and returns the address of a temporary
836 class object of the 'declared' type. */
838 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
839 gfc_typespec class_ts
)
847 /* The intrinsic type needs to be converted to a temporary
849 tmp
= gfc_typenode_for_spec (&class_ts
);
850 var
= gfc_create_var (tmp
, "class");
853 ctree
= gfc_class_vptr_get (var
);
855 vtab
= gfc_find_vtab (&e
->ts
);
857 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
858 gfc_add_modify (&parmse
->pre
, ctree
,
859 fold_convert (TREE_TYPE (ctree
), tmp
));
861 /* Now set the data field. */
862 ctree
= gfc_class_data_get (var
);
863 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
865 /* For an array reference in an elemental procedure call we need
866 to retain the ss to provide the scalarized array reference. */
867 gfc_conv_expr_reference (parmse
, e
);
868 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
869 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
873 ss
= gfc_walk_expr (e
);
874 if (ss
== gfc_ss_terminator
)
877 gfc_conv_expr_reference (parmse
, e
);
878 if (class_ts
.u
.derived
->components
->as
879 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
881 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
883 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
884 TREE_TYPE (ctree
), tmp
);
887 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
888 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
893 parmse
->use_offset
= 1;
894 gfc_conv_expr_descriptor (parmse
, e
);
895 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
897 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
898 TREE_TYPE (ctree
), parmse
->expr
);
899 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
902 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
906 gcc_assert (class_ts
.type
== BT_CLASS
);
907 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
908 && class_ts
.u
.derived
->components
->ts
.u
.derived
909 ->attr
.unlimited_polymorphic
)
911 ctree
= gfc_class_len_get (var
);
912 /* When the actual arg is a char array, then set the _len component of the
913 unlimited polymorphic entity to the length of the string. */
914 if (e
->ts
.type
== BT_CHARACTER
)
916 /* Start with parmse->string_length because this seems to be set to a
917 correct value more often. */
918 if (parmse
->string_length
)
919 tmp
= parmse
->string_length
;
920 /* When the string_length is not yet set, then try the backend_decl of
922 else if (e
->ts
.u
.cl
->backend_decl
)
923 tmp
= e
->ts
.u
.cl
->backend_decl
;
924 /* If both of the above approaches fail, then try to generate an
925 expression from the input, which is only feasible currently, when the
926 expression can be evaluated to a constant one. */
929 /* Try to simplify the expression. */
930 gfc_simplify_expr (e
, 0);
931 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
933 /* Amazingly all data is present to compute the length of a
934 constant string, but the expression is not yet there. */
935 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
936 gfc_charlen_int_kind
,
938 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
939 e
->value
.character
.length
);
940 gfc_conv_const_charlen (e
->ts
.u
.cl
);
941 e
->ts
.u
.cl
->resolved
= 1;
942 tmp
= e
->ts
.u
.cl
->backend_decl
;
946 gfc_error ("Cannot compute the length of the char array "
947 "at %L.", &e
->where
);
952 tmp
= integer_zero_node
;
954 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
956 else if (class_ts
.type
== BT_CLASS
957 && class_ts
.u
.derived
->components
958 && class_ts
.u
.derived
->components
->ts
.u
959 .derived
->attr
.unlimited_polymorphic
)
961 ctree
= gfc_class_len_get (var
);
962 gfc_add_modify (&parmse
->pre
, ctree
,
963 fold_convert (TREE_TYPE (ctree
),
966 /* Pass the address of the class object. */
967 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
971 /* Takes a scalarized class array expression and returns the
972 address of a temporary scalar class object of the 'declared'
974 OOP-TODO: This could be improved by adding code that branched on
975 the dynamic type being the same as the declared type. In this case
976 the original class expression can be passed directly.
977 optional_alloc_ptr is false when the dummy is neither allocatable
978 nor a pointer; that's relevant for the optional handling.
979 Set copyback to true if class container's _data and _vtab pointers
980 might get modified. */
983 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
984 bool elemental
, bool copyback
, bool optional
,
985 bool optional_alloc_ptr
)
991 tree cond
= NULL_TREE
;
992 tree slen
= NULL_TREE
;
996 bool full_array
= false;
998 gfc_init_block (&block
);
1001 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1003 if (ref
->type
== REF_COMPONENT
1004 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1007 if (ref
->next
== NULL
)
1011 if ((ref
== NULL
|| class_ref
== ref
)
1012 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1013 && (!class_ts
.u
.derived
->components
->as
1014 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1017 /* Test for FULL_ARRAY. */
1018 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1019 && gfc_expr_attr (e
).dimension
)
1022 gfc_is_class_array_ref (e
, &full_array
);
1024 /* The derived type needs to be converted to a temporary
1026 tmp
= gfc_typenode_for_spec (&class_ts
);
1027 var
= gfc_create_var (tmp
, "class");
1030 ctree
= gfc_class_data_get (var
);
1031 if (class_ts
.u
.derived
->components
->as
1032 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1036 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1038 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1039 gfc_get_dtype (type
));
1041 tmp
= gfc_class_data_get (parmse
->expr
);
1042 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1043 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1045 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1048 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1052 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1053 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1054 TREE_TYPE (ctree
), parmse
->expr
);
1055 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1058 /* Return the data component, except in the case of scalarized array
1059 references, where nullification of the cannot occur and so there
1061 if (!elemental
&& full_array
&& copyback
)
1063 if (class_ts
.u
.derived
->components
->as
1064 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1067 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1068 gfc_conv_descriptor_data_get (ctree
));
1070 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1073 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1077 ctree
= gfc_class_vptr_get (var
);
1079 /* The vptr is the second field of the actual argument.
1080 First we have to find the corresponding class reference. */
1083 if (gfc_is_class_array_function (e
)
1084 && parmse
->class_vptr
!= NULL_TREE
)
1085 tmp
= parmse
->class_vptr
;
1086 else if (class_ref
== NULL
1087 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1089 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1091 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1092 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1094 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1095 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1097 slen
= build_zero_cst (size_type_node
);
1101 /* Remove everything after the last class reference, convert the
1102 expression and then recover its tailend once more. */
1104 ref
= class_ref
->next
;
1105 class_ref
->next
= NULL
;
1106 gfc_init_se (&tmpse
, NULL
);
1107 gfc_conv_expr (&tmpse
, e
);
1108 class_ref
->next
= ref
;
1110 slen
= tmpse
.string_length
;
1113 gcc_assert (tmp
!= NULL_TREE
);
1115 /* Dereference if needs be. */
1116 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1117 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1119 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1120 vptr
= gfc_class_vptr_get (tmp
);
1124 gfc_add_modify (&block
, ctree
,
1125 fold_convert (TREE_TYPE (ctree
), vptr
));
1127 /* Return the vptr component, except in the case of scalarized array
1128 references, where the dynamic type cannot change. */
1129 if (!elemental
&& full_array
&& copyback
)
1130 gfc_add_modify (&parmse
->post
, vptr
,
1131 fold_convert (TREE_TYPE (vptr
), ctree
));
1133 /* For unlimited polymorphic objects also set the _len component. */
1134 if (class_ts
.type
== BT_CLASS
1135 && class_ts
.u
.derived
->components
1136 && class_ts
.u
.derived
->components
->ts
.u
1137 .derived
->attr
.unlimited_polymorphic
)
1139 ctree
= gfc_class_len_get (var
);
1140 if (UNLIMITED_POLY (e
))
1141 tmp
= gfc_class_len_get (tmp
);
1142 else if (e
->ts
.type
== BT_CHARACTER
)
1144 gcc_assert (slen
!= NULL_TREE
);
1148 tmp
= build_zero_cst (size_type_node
);
1149 gfc_add_modify (&parmse
->pre
, ctree
,
1150 fold_convert (TREE_TYPE (ctree
), tmp
));
1152 /* Return the len component, except in the case of scalarized array
1153 references, where the dynamic type cannot change. */
1154 if (!elemental
&& full_array
&& copyback
1155 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1156 gfc_add_modify (&parmse
->post
, tmp
,
1157 fold_convert (TREE_TYPE (tmp
), ctree
));
1164 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1165 /* parmse->pre may contain some preparatory instructions for the
1166 temporary array descriptor. Those may only be executed when the
1167 optional argument is set, therefore add parmse->pre's instructions
1168 to block, which is later guarded by an if (optional_arg_given). */
1169 gfc_add_block_to_block (&parmse
->pre
, &block
);
1170 block
.head
= parmse
->pre
.head
;
1171 parmse
->pre
.head
= NULL_TREE
;
1172 tmp
= gfc_finish_block (&block
);
1174 if (optional_alloc_ptr
)
1175 tmp2
= build_empty_stmt (input_location
);
1178 gfc_init_block (&block
);
1180 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1181 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1182 null_pointer_node
));
1183 tmp2
= gfc_finish_block (&block
);
1186 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1188 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1191 gfc_add_block_to_block (&parmse
->pre
, &block
);
1193 /* Pass the address of the class object. */
1194 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1196 if (optional
&& optional_alloc_ptr
)
1197 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1198 TREE_TYPE (parmse
->expr
),
1200 fold_convert (TREE_TYPE (parmse
->expr
),
1201 null_pointer_node
));
1205 /* Given a class array declaration and an index, returns the address
1206 of the referenced element. */
1209 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1212 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1214 data
= data_comp
!= NULL_TREE
? data_comp
:
1215 gfc_class_data_get (class_decl
);
1216 size
= gfc_class_vtab_size_get (class_decl
);
1220 tmp
= fold_convert (gfc_array_index_type
,
1221 gfc_class_len_get (class_decl
));
1222 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1223 gfc_array_index_type
, size
, tmp
);
1224 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1225 logical_type_node
, tmp
,
1226 build_zero_cst (TREE_TYPE (tmp
)));
1227 size
= fold_build3_loc (input_location
, COND_EXPR
,
1228 gfc_array_index_type
, tmp
, ctmp
, size
);
1231 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1232 gfc_array_index_type
,
1235 data
= gfc_conv_descriptor_data_get (data
);
1236 ptr
= fold_convert (pvoid_type_node
, data
);
1237 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1238 return fold_convert (TREE_TYPE (data
), ptr
);
1242 /* Copies one class expression to another, assuming that if either
1243 'to' or 'from' are arrays they are packed. Should 'from' be
1244 NULL_TREE, the initialization expression for 'to' is used, assuming
1245 that the _vptr is set. */
1248 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1258 vec
<tree
, va_gc
> *args
;
1263 bool is_from_desc
= false, is_to_class
= false;
1266 /* To prevent warnings on uninitialized variables. */
1267 from_len
= to_len
= NULL_TREE
;
1269 if (from
!= NULL_TREE
)
1270 fcn
= gfc_class_vtab_copy_get (from
);
1272 fcn
= gfc_class_vtab_copy_get (to
);
1274 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1276 if (from
!= NULL_TREE
)
1278 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1282 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1286 /* Check that from is a class. When the class is part of a coarray,
1287 then from is a common pointer and is to be used as is. */
1288 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1289 ? build_fold_indirect_ref (from
) : from
;
1291 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1292 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1293 ? gfc_class_data_get (from
) : from
;
1294 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1298 from_data
= gfc_class_vtab_def_init_get (to
);
1302 if (from
!= NULL_TREE
&& unlimited
)
1303 from_len
= gfc_class_len_or_zero_get (from
);
1305 from_len
= build_zero_cst (size_type_node
);
1308 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1311 to_data
= gfc_class_data_get (to
);
1313 to_len
= gfc_class_len_get (to
);
1316 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1319 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1321 stmtblock_t loopbody
;
1325 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1327 gfc_init_block (&body
);
1328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1329 gfc_array_index_type
, nelems
,
1330 gfc_index_one_node
);
1331 nelems
= gfc_evaluate_now (tmp
, &body
);
1332 index
= gfc_create_var (gfc_array_index_type
, "S");
1336 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1338 vec_safe_push (args
, from_ref
);
1341 vec_safe_push (args
, from_data
);
1344 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1347 tmp
= gfc_conv_array_data (to
);
1348 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1349 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1350 gfc_build_array_ref (tmp
, index
, to
));
1352 vec_safe_push (args
, to_ref
);
1354 /* Add bounds check. */
1355 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1358 const char *name
= "<<unknown>>";
1362 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1364 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1365 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1366 logical_type_node
, from_len
, orig_nelems
);
1367 msg
= xasprintf ("Array bound mismatch for dimension %d "
1368 "of array '%s' (%%ld/%%ld)",
1371 gfc_trans_runtime_check (true, false, tmp
, &body
,
1372 &gfc_current_locus
, msg
,
1373 fold_convert (long_integer_type_node
, orig_nelems
),
1374 fold_convert (long_integer_type_node
, from_len
));
1379 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody
);
1383 gfc_add_expr_to_block (&loopbody
, tmp
);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop
);
1388 loop
.from
[0] = gfc_index_zero_node
;
1389 loop
.loopvar
[0] = index
;
1390 loop
.to
[0] = nelems
;
1391 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1392 gfc_init_block (&ifbody
);
1393 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1394 stdcopy
= gfc_finish_block (&ifbody
);
1395 /* In initialization mode from_len is a constant zero. */
1396 if (unlimited
&& !integer_zerop (from_len
))
1398 vec_safe_push (args
, from_len
);
1399 vec_safe_push (args
, to_len
);
1400 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1401 /* Build the body of the loop. */
1402 gfc_init_block (&loopbody
);
1403 gfc_add_expr_to_block (&loopbody
, tmp
);
1405 /* Build the loop and return. */
1406 gfc_init_loopinfo (&loop
);
1408 loop
.from
[0] = gfc_index_zero_node
;
1409 loop
.loopvar
[0] = index
;
1410 loop
.to
[0] = nelems
;
1411 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1412 gfc_init_block (&ifbody
);
1413 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1414 extcopy
= gfc_finish_block (&ifbody
);
1416 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1417 logical_type_node
, from_len
,
1418 build_zero_cst (TREE_TYPE (from_len
)));
1419 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1420 void_type_node
, tmp
, extcopy
, stdcopy
);
1421 gfc_add_expr_to_block (&body
, tmp
);
1422 tmp
= gfc_finish_block (&body
);
1426 gfc_add_expr_to_block (&body
, stdcopy
);
1427 tmp
= gfc_finish_block (&body
);
1429 gfc_cleanup_loop (&loop
);
1433 gcc_assert (!is_from_desc
);
1434 vec_safe_push (args
, from_data
);
1435 vec_safe_push (args
, to_data
);
1436 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1438 /* In initialization mode from_len is a constant zero. */
1439 if (unlimited
&& !integer_zerop (from_len
))
1441 vec_safe_push (args
, from_len
);
1442 vec_safe_push (args
, to_len
);
1443 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1444 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1445 logical_type_node
, from_len
,
1446 build_zero_cst (TREE_TYPE (from_len
)));
1447 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1448 void_type_node
, tmp
, extcopy
, stdcopy
);
1454 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1455 if (from
== NULL_TREE
)
1458 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1460 from_data
, null_pointer_node
);
1461 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1462 void_type_node
, cond
,
1463 tmp
, build_empty_stmt (input_location
));
1471 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1473 gfc_actual_arglist
*actual
;
1478 actual
= gfc_get_actual_arglist ();
1479 actual
->expr
= gfc_copy_expr (rhs
);
1480 actual
->next
= gfc_get_actual_arglist ();
1481 actual
->next
->expr
= gfc_copy_expr (lhs
);
1482 ppc
= gfc_copy_expr (obj
);
1483 gfc_add_vptr_component (ppc
);
1484 gfc_add_component_ref (ppc
, "_copy");
1485 ppc_code
= gfc_get_code (EXEC_CALL
);
1486 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1487 /* Although '_copy' is set to be elemental in class.c, it is
1488 not staying that way. Find out why, sometime.... */
1489 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1490 ppc_code
->ext
.actual
= actual
;
1491 ppc_code
->expr1
= ppc
;
1492 /* Since '_copy' is elemental, the scalarizer will take care
1493 of arrays in gfc_trans_call. */
1494 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1495 gfc_free_statements (ppc_code
);
1497 if (UNLIMITED_POLY(obj
))
1499 /* Check if rhs is non-NULL. */
1501 gfc_init_se (&src
, NULL
);
1502 gfc_conv_expr (&src
, rhs
);
1503 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1504 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1505 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1506 null_pointer_node
));
1507 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1508 build_empty_stmt (input_location
));
1514 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1515 A MEMCPY is needed to copy the full data from the default initializer
1516 of the dynamic type. */
1519 gfc_trans_class_init_assign (gfc_code
*code
)
1523 gfc_se dst
,src
,memsz
;
1524 gfc_expr
*lhs
, *rhs
, *sz
;
1526 gfc_start_block (&block
);
1528 lhs
= gfc_copy_expr (code
->expr1
);
1530 rhs
= gfc_copy_expr (code
->expr1
);
1531 gfc_add_vptr_component (rhs
);
1533 /* Make sure that the component backend_decls have been built, which
1534 will not have happened if the derived types concerned have not
1536 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1537 gfc_add_def_init_component (rhs
);
1538 /* The _def_init is always scalar. */
1541 if (code
->expr1
->ts
.type
== BT_CLASS
1542 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1544 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1545 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1546 /* Adding the array ref to the class expression results in correct
1547 indexing to the dynamic type. */
1548 gfc_add_full_array_ref (lhs
, tmparr
);
1549 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1553 /* Scalar initialization needs the _data component. */
1554 gfc_add_data_component (lhs
);
1555 sz
= gfc_copy_expr (code
->expr1
);
1556 gfc_add_vptr_component (sz
);
1557 gfc_add_size_component (sz
);
1559 gfc_init_se (&dst
, NULL
);
1560 gfc_init_se (&src
, NULL
);
1561 gfc_init_se (&memsz
, NULL
);
1562 gfc_conv_expr (&dst
, lhs
);
1563 gfc_conv_expr (&src
, rhs
);
1564 gfc_conv_expr (&memsz
, sz
);
1565 gfc_add_block_to_block (&block
, &src
.pre
);
1566 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1568 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1570 if (UNLIMITED_POLY(code
->expr1
))
1572 /* Check if _def_init is non-NULL. */
1573 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1574 logical_type_node
, src
.expr
,
1575 fold_convert (TREE_TYPE (src
.expr
),
1576 null_pointer_node
));
1577 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1578 tmp
, build_empty_stmt (input_location
));
1582 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1583 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1585 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1586 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1588 build_empty_stmt (input_location
));
1591 gfc_add_expr_to_block (&block
, tmp
);
1593 return gfc_finish_block (&block
);
1597 /* End of prototype trans-class.c */
1601 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1603 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1604 gfc_warning (OPT_Wrealloc_lhs
,
1605 "Code for reallocating the allocatable array at %L will "
1607 else if (warn_realloc_lhs_all
)
1608 gfc_warning (OPT_Wrealloc_lhs_all
,
1609 "Code for reallocating the allocatable variable at %L "
1610 "will be added", where
);
1614 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1617 /* Copy the scalarization loop variables. */
1620 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1623 dest
->loop
= src
->loop
;
1627 /* Initialize a simple expression holder.
1629 Care must be taken when multiple se are created with the same parent.
1630 The child se must be kept in sync. The easiest way is to delay creation
1631 of a child se until after after the previous se has been translated. */
1634 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1636 memset (se
, 0, sizeof (gfc_se
));
1637 gfc_init_block (&se
->pre
);
1638 gfc_init_block (&se
->post
);
1640 se
->parent
= parent
;
1643 gfc_copy_se_loopvars (se
, parent
);
1647 /* Advances to the next SS in the chain. Use this rather than setting
1648 se->ss = se->ss->next because all the parents needs to be kept in sync.
1652 gfc_advance_se_ss_chain (gfc_se
* se
)
1657 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1660 /* Walk down the parent chain. */
1663 /* Simple consistency check. */
1664 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1665 || p
->parent
->ss
->nested_ss
== p
->ss
);
1667 /* If we were in a nested loop, the next scalarized expression can be
1668 on the parent ss' next pointer. Thus we should not take the next
1669 pointer blindly, but rather go up one nest level as long as next
1670 is the end of chain. */
1672 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1682 /* Ensures the result of the expression as either a temporary variable
1683 or a constant so that it can be used repeatedly. */
1686 gfc_make_safe_expr (gfc_se
* se
)
1690 if (CONSTANT_CLASS_P (se
->expr
))
1693 /* We need a temporary for this result. */
1694 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1695 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1700 /* Return an expression which determines if a dummy parameter is present.
1701 Also used for arguments to procedures with multiple entry points. */
1704 gfc_conv_expr_present (gfc_symbol
* sym
)
1708 gcc_assert (sym
->attr
.dummy
);
1709 decl
= gfc_get_symbol_decl (sym
);
1711 /* Intrinsic scalars with VALUE attribute which are passed by value
1712 use a hidden argument to denote the present status. */
1713 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1714 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1715 && !sym
->attr
.dimension
)
1717 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1720 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1722 strcpy (&name
[1], sym
->name
);
1723 tree_name
= get_identifier (name
);
1725 /* Walk function argument list to find hidden arg. */
1726 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1727 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1728 if (DECL_NAME (cond
) == tree_name
1729 && DECL_ARTIFICIAL (cond
))
1736 if (TREE_CODE (decl
) != PARM_DECL
)
1738 /* Array parameters use a temporary descriptor, we want the real
1740 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1741 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1742 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1745 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1746 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1748 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1749 as actual argument to denote absent dummies. For array descriptors,
1750 we thus also need to check the array descriptor. For BT_CLASS, it
1751 can also occur for scalars and F2003 due to type->class wrapping and
1752 class->class wrapping. Note further that BT_CLASS always uses an
1753 array descriptor for arrays, also for explicit-shape/assumed-size. */
1755 if (!sym
->attr
.allocatable
1756 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1757 || (sym
->ts
.type
== BT_CLASS
1758 && !CLASS_DATA (sym
)->attr
.allocatable
1759 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1760 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1761 || sym
->ts
.type
== BT_CLASS
))
1765 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1766 || sym
->as
->type
== AS_ASSUMED_RANK
1767 || sym
->attr
.codimension
))
1768 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1770 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1771 if (sym
->ts
.type
== BT_CLASS
)
1772 tmp
= gfc_class_data_get (tmp
);
1773 tmp
= gfc_conv_array_data (tmp
);
1775 else if (sym
->ts
.type
== BT_CLASS
)
1776 tmp
= gfc_class_data_get (decl
);
1780 if (tmp
!= NULL_TREE
)
1782 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1783 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1784 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1785 logical_type_node
, cond
, tmp
);
1793 /* Converts a missing, dummy argument into a null or zero. */
1796 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1801 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1805 /* Create a temporary and convert it to the correct type. */
1806 tmp
= gfc_get_int_type (kind
);
1807 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1810 /* Test for a NULL value. */
1811 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1812 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1813 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1814 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1818 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1820 build_zero_cst (TREE_TYPE (se
->expr
)));
1821 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1825 if (ts
.type
== BT_CHARACTER
)
1827 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1828 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1829 present
, se
->string_length
, tmp
);
1830 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1831 se
->string_length
= tmp
;
1837 /* Get the character length of an expression, looking through gfc_refs
1841 gfc_get_expr_charlen (gfc_expr
*e
)
1847 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1848 && e
->ts
.type
== BT_CHARACTER
);
1850 length
= NULL
; /* To silence compiler warning. */
1852 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1855 gfc_init_se (&tmpse
, NULL
);
1856 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1857 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1861 /* First candidate: if the variable is of type CHARACTER, the
1862 expression's length could be the length of the character
1864 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1865 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1867 /* Look through the reference chain for component references. */
1868 for (r
= e
->ref
; r
; r
= r
->next
)
1873 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1874 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1882 gfc_init_se (&se
, NULL
);
1883 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
1885 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
1886 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
1887 gfc_charlen_type_node
,
1889 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
1890 gfc_charlen_type_node
, length
,
1891 gfc_index_one_node
);
1900 gcc_assert (length
!= NULL
);
1905 /* Return for an expression the backend decl of the coarray. */
1908 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1914 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1916 /* Not-implemented diagnostic. */
1917 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1918 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1919 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1920 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1921 "%L is not supported", &expr
->where
);
1923 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1924 if (ref
->type
== REF_COMPONENT
)
1926 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1927 && UNLIMITED_POLY (ref
->u
.c
.component
)
1928 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1929 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1930 "component at %L is not supported", &expr
->where
);
1933 /* Make sure the backend_decl is present before accessing it. */
1934 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1935 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1936 : expr
->symtree
->n
.sym
->backend_decl
;
1938 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1940 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1942 caf_decl
= gfc_class_data_get (caf_decl
);
1943 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1946 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1948 if (ref
->type
== REF_COMPONENT
1949 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1951 caf_decl
= gfc_class_data_get (caf_decl
);
1952 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1956 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1960 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1963 /* The following code assumes that the coarray is a component reachable via
1964 only scalar components/variables; the Fortran standard guarantees this. */
1966 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1967 if (ref
->type
== REF_COMPONENT
)
1969 gfc_component
*comp
= ref
->u
.c
.component
;
1971 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1972 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1973 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1974 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1975 comp
->backend_decl
, NULL_TREE
);
1976 if (comp
->ts
.type
== BT_CLASS
)
1978 caf_decl
= gfc_class_data_get (caf_decl
);
1979 if (CLASS_DATA (comp
)->attr
.codimension
)
1985 if (comp
->attr
.codimension
)
1991 gcc_assert (found
&& caf_decl
);
1996 /* Obtain the Coarray token - and optionally also the offset. */
1999 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2000 tree se_expr
, gfc_expr
*expr
)
2004 /* Coarray token. */
2005 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2007 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2008 == GFC_ARRAY_ALLOCATABLE
2009 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2010 *token
= gfc_conv_descriptor_token (caf_decl
);
2012 else if (DECL_LANG_SPECIFIC (caf_decl
)
2013 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2014 *token
= GFC_DECL_TOKEN (caf_decl
);
2017 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2018 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2019 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2025 /* Offset between the coarray base address and the address wanted. */
2026 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2027 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2028 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2029 *offset
= build_int_cst (gfc_array_index_type
, 0);
2030 else if (DECL_LANG_SPECIFIC (caf_decl
)
2031 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2032 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2033 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2034 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2036 *offset
= build_int_cst (gfc_array_index_type
, 0);
2038 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2039 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2041 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2042 tmp
= gfc_conv_descriptor_data_get (tmp
);
2044 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2045 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2048 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2052 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2053 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2055 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2056 && expr
->symtree
->n
.sym
->attr
.codimension
2057 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2059 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2060 gfc_ref
*ref
= base_expr
->ref
;
2063 // Iterate through the refs until the last one.
2067 if (ref
->type
== REF_ARRAY
2068 && ref
->u
.ar
.type
!= AR_FULL
)
2070 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2072 for (i
= 0; i
< ranksum
; ++i
)
2074 ref
->u
.ar
.start
[i
] = NULL
;
2075 ref
->u
.ar
.end
[i
] = NULL
;
2077 ref
->u
.ar
.type
= AR_FULL
;
2079 gfc_init_se (&base_se
, NULL
);
2080 if (gfc_caf_attr (base_expr
).dimension
)
2082 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2083 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2087 gfc_conv_expr (&base_se
, base_expr
);
2091 gfc_free_expr (base_expr
);
2092 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2093 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2095 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2096 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2099 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2103 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2104 fold_convert (gfc_array_index_type
, *offset
),
2105 fold_convert (gfc_array_index_type
, tmp
));
2109 /* Convert the coindex of a coarray into an image index; the result is
2110 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2111 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2114 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2117 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2121 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2122 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2124 gcc_assert (ref
!= NULL
);
2126 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2128 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2132 img_idx
= build_zero_cst (gfc_array_index_type
);
2133 extent
= build_one_cst (gfc_array_index_type
);
2134 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2135 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2137 gfc_init_se (&se
, NULL
);
2138 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2139 gfc_add_block_to_block (block
, &se
.pre
);
2140 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2141 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2142 TREE_TYPE (lbound
), se
.expr
, lbound
);
2143 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2145 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2146 TREE_TYPE (tmp
), img_idx
, tmp
);
2147 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2149 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2150 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2151 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2152 TREE_TYPE (tmp
), extent
, tmp
);
2156 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2158 gfc_init_se (&se
, NULL
);
2159 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2160 gfc_add_block_to_block (block
, &se
.pre
);
2161 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2162 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2163 TREE_TYPE (lbound
), se
.expr
, lbound
);
2164 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2166 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2168 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2170 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2171 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2172 TREE_TYPE (ubound
), ubound
, lbound
);
2173 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2174 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2175 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2176 TREE_TYPE (tmp
), extent
, tmp
);
2179 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2180 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2181 return fold_convert (integer_type_node
, img_idx
);
2185 /* For each character array constructor subexpression without a ts.u.cl->length,
2186 replace it by its first element (if there aren't any elements, the length
2187 should already be set to zero). */
2190 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2192 gfc_actual_arglist
* arg
;
2198 switch (e
->expr_type
)
2202 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2203 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2207 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2211 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2212 flatten_array_ctors_without_strlen (arg
->expr
);
2217 /* We've found what we're looking for. */
2218 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2223 gcc_assert (e
->value
.constructor
);
2225 c
= gfc_constructor_first (e
->value
.constructor
);
2229 flatten_array_ctors_without_strlen (new_expr
);
2230 gfc_replace_expr (e
, new_expr
);
2234 /* Otherwise, fall through to handle constructor elements. */
2236 case EXPR_STRUCTURE
:
2237 for (c
= gfc_constructor_first (e
->value
.constructor
);
2238 c
; c
= gfc_constructor_next (c
))
2239 flatten_array_ctors_without_strlen (c
->expr
);
2249 /* Generate code to initialize a string length variable. Returns the
2250 value. For array constructors, cl->length might be NULL and in this case,
2251 the first element of the constructor is needed. expr is the original
2252 expression so we can access it but can be NULL if this is not needed. */
2255 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2259 gfc_init_se (&se
, NULL
);
2261 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2264 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2265 "flatten" array constructors by taking their first element; all elements
2266 should be the same length or a cl->length should be present. */
2269 gfc_expr
* expr_flat
;
2272 expr_flat
= gfc_copy_expr (expr
);
2273 flatten_array_ctors_without_strlen (expr_flat
);
2274 gfc_resolve_expr (expr_flat
);
2276 gfc_conv_expr (&se
, expr_flat
);
2277 gfc_add_block_to_block (pblock
, &se
.pre
);
2278 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2280 gfc_free_expr (expr_flat
);
2284 /* Convert cl->length. */
2286 gcc_assert (cl
->length
);
2288 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2289 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2290 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2291 gfc_add_block_to_block (pblock
, &se
.pre
);
2293 if (cl
->backend_decl
)
2294 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2296 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2301 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2302 const char *name
, locus
*where
)
2312 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2313 type
= build_pointer_type (type
);
2315 gfc_init_se (&start
, se
);
2316 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2317 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2319 if (integer_onep (start
.expr
))
2320 gfc_conv_string_parameter (se
);
2325 /* Avoid multiple evaluation of substring start. */
2326 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2327 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2329 /* Change the start of the string. */
2330 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2331 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2332 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2335 tmp
= build_fold_indirect_ref_loc (input_location
,
2337 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2338 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2341 /* Length = end + 1 - start. */
2342 gfc_init_se (&end
, se
);
2343 if (ref
->u
.ss
.end
== NULL
)
2344 end
.expr
= se
->string_length
;
2347 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2348 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2352 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2353 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2355 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2357 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2358 logical_type_node
, start
.expr
,
2361 /* Check lower bound. */
2362 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2364 build_one_cst (TREE_TYPE (start
.expr
)));
2365 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2366 logical_type_node
, nonempty
, fault
);
2368 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2369 "is less than one", name
);
2371 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2372 "is less than one");
2373 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2374 fold_convert (long_integer_type_node
,
2378 /* Check upper bound. */
2379 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2380 end
.expr
, se
->string_length
);
2381 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2382 logical_type_node
, nonempty
, fault
);
2384 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2385 "exceeds string length (%%ld)", name
);
2387 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2388 "exceeds string length (%%ld)");
2389 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2390 fold_convert (long_integer_type_node
, end
.expr
),
2391 fold_convert (long_integer_type_node
,
2392 se
->string_length
));
2396 /* Try to calculate the length from the start and end expressions. */
2398 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2400 HOST_WIDE_INT i_len
;
2402 i_len
= gfc_mpz_get_hwi (length
) + 1;
2406 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2407 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2411 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2412 fold_convert (gfc_charlen_type_node
, end
.expr
),
2413 fold_convert (gfc_charlen_type_node
, start
.expr
));
2414 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2415 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2416 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2417 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2420 se
->string_length
= tmp
;
2424 /* Convert a derived type component reference. */
2427 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2435 c
= ref
->u
.c
.component
;
2437 if (c
->backend_decl
== NULL_TREE
2438 && ref
->u
.c
.sym
!= NULL
)
2439 gfc_get_derived_type (ref
->u
.c
.sym
);
2441 field
= c
->backend_decl
;
2442 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2444 context
= DECL_FIELD_CONTEXT (field
);
2446 /* Components can correspond to fields of different containing
2447 types, as components are created without context, whereas
2448 a concrete use of a component has the type of decl as context.
2449 So, if the type doesn't match, we search the corresponding
2450 FIELD_DECL in the parent type. To not waste too much time
2451 we cache this result in norestrict_decl.
2452 On the other hand, if the context is a UNION or a MAP (a
2453 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2455 if (context
!= TREE_TYPE (decl
)
2456 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2457 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2459 tree f2
= c
->norestrict_decl
;
2460 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2461 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2462 if (TREE_CODE (f2
) == FIELD_DECL
2463 && DECL_NAME (f2
) == DECL_NAME (field
))
2466 c
->norestrict_decl
= f2
;
2470 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2471 && strcmp ("_data", c
->name
) == 0)
2473 /* Found a ref to the _data component. Store the associated ref to
2474 the vptr in se->class_vptr. */
2475 se
->class_vptr
= gfc_class_vptr_get (decl
);
2478 se
->class_vptr
= NULL_TREE
;
2480 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2481 decl
, field
, NULL_TREE
);
2485 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2486 strlen () conditional below. */
2487 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2488 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2489 && !c
->attr
.pdt_string
)
2491 tmp
= c
->ts
.u
.cl
->backend_decl
;
2492 /* Components must always be constant length. */
2493 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2494 se
->string_length
= tmp
;
2497 if (gfc_deferred_strlen (c
, &field
))
2499 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2501 decl
, field
, NULL_TREE
);
2502 se
->string_length
= tmp
;
2505 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2506 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2507 && c
->ts
.type
!= BT_CHARACTER
)
2508 || c
->attr
.proc_pointer
)
2509 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2514 /* This function deals with component references to components of the
2515 parent type for derived type extensions. */
2517 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2525 c
= ref
->u
.c
.component
;
2527 /* Return if the component is in the parent type. */
2528 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2529 if (strcmp (c
->name
, cmp
->name
) == 0)
2532 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2533 parent
.type
= REF_COMPONENT
;
2535 parent
.u
.c
.sym
= dt
;
2536 parent
.u
.c
.component
= dt
->components
;
2538 if (dt
->backend_decl
== NULL
)
2539 gfc_get_derived_type (dt
);
2541 /* Build the reference and call self. */
2542 gfc_conv_component_ref (se
, &parent
);
2543 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2544 parent
.u
.c
.component
= c
;
2545 conv_parent_component_references (se
, &parent
);
2550 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2552 tree res
= se
->expr
;
2557 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2558 TREE_TYPE (TREE_TYPE (res
)), res
);
2562 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2563 TREE_TYPE (TREE_TYPE (res
)), res
);
2567 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2572 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2582 /* Dereference VAR where needed if it is a pointer, reference, etc.
2583 according to Fortran semantics. */
2586 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2589 /* Characters are entirely different from other types, they are treated
2591 if (sym
->ts
.type
== BT_CHARACTER
)
2593 /* Dereference character pointer dummy arguments
2595 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2597 || sym
->attr
.function
2598 || sym
->attr
.result
))
2599 var
= build_fold_indirect_ref_loc (input_location
, var
);
2601 else if (!sym
->attr
.value
)
2603 /* Dereference temporaries for class array dummy arguments. */
2604 if (sym
->attr
.dummy
&& is_classarray
2605 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2607 if (!descriptor_only_p
)
2608 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2610 var
= build_fold_indirect_ref_loc (input_location
, var
);
2613 /* Dereference non-character scalar dummy arguments. */
2614 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2615 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2616 && (sym
->ts
.type
!= BT_CLASS
2617 || (!CLASS_DATA (sym
)->attr
.dimension
2618 && !(CLASS_DATA (sym
)->attr
.codimension
2619 && CLASS_DATA (sym
)->attr
.allocatable
))))
2620 var
= build_fold_indirect_ref_loc (input_location
, var
);
2622 /* Dereference scalar hidden result. */
2623 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2624 && (sym
->attr
.function
|| sym
->attr
.result
)
2625 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2626 && !sym
->attr
.always_explicit
)
2627 var
= build_fold_indirect_ref_loc (input_location
, var
);
2629 /* Dereference non-character, non-class pointer variables.
2630 These must be dummies, results, or scalars. */
2632 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2633 || gfc_is_associate_pointer (sym
)
2634 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2636 || sym
->attr
.function
2638 || (!sym
->attr
.dimension
2639 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2640 var
= build_fold_indirect_ref_loc (input_location
, var
);
2641 /* Now treat the class array pointer variables accordingly. */
2642 else if (sym
->ts
.type
== BT_CLASS
2644 && (CLASS_DATA (sym
)->attr
.dimension
2645 || CLASS_DATA (sym
)->attr
.codimension
)
2646 && ((CLASS_DATA (sym
)->as
2647 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2648 || CLASS_DATA (sym
)->attr
.allocatable
2649 || CLASS_DATA (sym
)->attr
.class_pointer
))
2650 var
= build_fold_indirect_ref_loc (input_location
, var
);
2651 /* And the case where a non-dummy, non-result, non-function,
2652 non-allotable and non-pointer classarray is present. This case was
2653 previously covered by the first if, but with introducing the
2654 condition !is_classarray there, that case has to be covered
2656 else if (sym
->ts
.type
== BT_CLASS
2658 && !sym
->attr
.function
2659 && !sym
->attr
.result
2660 && (CLASS_DATA (sym
)->attr
.dimension
2661 || CLASS_DATA (sym
)->attr
.codimension
)
2663 || !CLASS_DATA (sym
)->attr
.allocatable
)
2664 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2665 var
= build_fold_indirect_ref_loc (input_location
, var
);
2671 /* Return the contents of a variable. Also handles reference/pointer
2672 variables (all Fortran pointer references are implicit). */
2675 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2680 tree parent_decl
= NULL_TREE
;
2683 bool alternate_entry
;
2686 bool first_time
= true;
2688 sym
= expr
->symtree
->n
.sym
;
2689 is_classarray
= IS_CLASS_ARRAY (sym
);
2693 gfc_ss_info
*ss_info
= ss
->info
;
2695 /* Check that something hasn't gone horribly wrong. */
2696 gcc_assert (ss
!= gfc_ss_terminator
);
2697 gcc_assert (ss_info
->expr
== expr
);
2699 /* A scalarized term. We already know the descriptor. */
2700 se
->expr
= ss_info
->data
.array
.descriptor
;
2701 se
->string_length
= ss_info
->string_length
;
2702 ref
= ss_info
->data
.array
.ref
;
2704 gcc_assert (ref
->type
== REF_ARRAY
2705 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2707 gfc_conv_tmp_array_ref (se
);
2711 tree se_expr
= NULL_TREE
;
2713 se
->expr
= gfc_get_symbol_decl (sym
);
2715 /* Deal with references to a parent results or entries by storing
2716 the current_function_decl and moving to the parent_decl. */
2717 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2718 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2719 && sym
->result
== sym
;
2720 entry_master
= sym
->attr
.result
2721 && sym
->ns
->proc_name
->attr
.entry_master
2722 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2723 if (current_function_decl
)
2724 parent_decl
= DECL_CONTEXT (current_function_decl
);
2726 if ((se
->expr
== parent_decl
&& return_value
)
2727 || (sym
->ns
&& sym
->ns
->proc_name
2729 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2730 && (alternate_entry
|| entry_master
)))
2735 /* Special case for assigning the return value of a function.
2736 Self recursive functions must have an explicit return value. */
2737 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2738 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2740 /* Similarly for alternate entry points. */
2741 else if (alternate_entry
2742 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2745 gfc_entry_list
*el
= NULL
;
2747 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2750 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2755 else if (entry_master
2756 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2758 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2763 /* Procedure actual arguments. Look out for temporary variables
2764 with the same attributes as function values. */
2765 else if (!sym
->attr
.temporary
2766 && sym
->attr
.flavor
== FL_PROCEDURE
2767 && se
->expr
!= current_function_decl
)
2769 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2771 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2772 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2777 /* Dereference the expression, where needed. */
2778 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
2784 /* For character variables, also get the length. */
2785 if (sym
->ts
.type
== BT_CHARACTER
)
2787 /* If the character length of an entry isn't set, get the length from
2788 the master function instead. */
2789 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2790 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2792 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2793 gcc_assert (se
->string_length
);
2796 gfc_typespec
*ts
= &sym
->ts
;
2802 /* Return the descriptor if that's what we want and this is an array
2803 section reference. */
2804 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2806 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2807 /* Return the descriptor for array pointers and allocations. */
2808 if (se
->want_pointer
2809 && ref
->next
== NULL
&& (se
->descriptor_only
))
2812 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2813 /* Return a pointer to an element. */
2817 ts
= &ref
->u
.c
.component
->ts
;
2818 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2819 && se
->descriptor_only
2820 && !CLASS_DATA (sym
)->attr
.allocatable
2821 && !CLASS_DATA (sym
)->attr
.class_pointer
2822 && CLASS_DATA (sym
)->as
2823 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2824 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2825 /* Skip the first ref of a _data component, because for class
2826 arrays that one is already done by introducing a temporary
2827 array descriptor. */
2830 if (ref
->u
.c
.sym
->attr
.extension
)
2831 conv_parent_component_references (se
, ref
);
2833 gfc_conv_component_ref (se
, ref
);
2834 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2835 && se
->want_pointer
&& se
->descriptor_only
)
2841 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2842 expr
->symtree
->name
, &expr
->where
);
2846 conv_inquiry (se
, ref
, expr
, ts
);
2856 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2858 if (se
->want_pointer
)
2860 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2861 gfc_conv_string_parameter (se
);
2863 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2868 /* Unary ops are easy... Or they would be if ! was a valid op. */
2871 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2876 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2877 /* Initialize the operand. */
2878 gfc_init_se (&operand
, se
);
2879 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2880 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2882 type
= gfc_typenode_for_spec (&expr
->ts
);
2884 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2885 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2886 All other unary operators have an equivalent GIMPLE unary operator. */
2887 if (code
== TRUTH_NOT_EXPR
)
2888 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2889 build_int_cst (type
, 0));
2891 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2895 /* Expand power operator to optimal multiplications when a value is raised
2896 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2897 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2898 Programming", 3rd Edition, 1998. */
2900 /* This code is mostly duplicated from expand_powi in the backend.
2901 We establish the "optimal power tree" lookup table with the defined size.
2902 The items in the table are the exponents used to calculate the index
2903 exponents. Any integer n less than the value can get an "addition chain",
2904 with the first node being one. */
2905 #define POWI_TABLE_SIZE 256
2907 /* The table is from builtins.c. */
2908 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2910 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2911 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2912 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2913 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2914 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2915 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2916 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2917 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2918 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2919 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2920 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2921 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2922 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2923 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2924 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2925 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2926 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2927 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2928 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2929 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2930 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2931 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2932 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2933 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2934 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2935 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2936 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2937 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2938 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2939 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2940 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2941 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2944 /* If n is larger than lookup table's max index, we use the "window
2946 #define POWI_WINDOW_SIZE 3
2948 /* Recursive function to expand the power operator. The temporary
2949 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2951 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2958 if (n
< POWI_TABLE_SIZE
)
2963 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2964 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2968 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2969 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2970 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2974 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2978 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2979 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2981 if (n
< POWI_TABLE_SIZE
)
2988 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2989 return 1. Else return 0 and a call to runtime library functions
2990 will have to be built. */
2992 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2997 tree vartmp
[POWI_TABLE_SIZE
];
2999 unsigned HOST_WIDE_INT n
;
3001 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3003 /* If exponent is too large, we won't expand it anyway, so don't bother
3004 with large integer values. */
3005 if (!wi::fits_shwi_p (wrhs
))
3008 m
= wrhs
.to_shwi ();
3009 /* Use the wide_int's routine to reliably get the absolute value on all
3010 platforms. Then convert it to a HOST_WIDE_INT like above. */
3011 n
= wi::abs (wrhs
).to_shwi ();
3013 type
= TREE_TYPE (lhs
);
3014 sgn
= tree_int_cst_sgn (rhs
);
3016 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3017 || optimize_size
) && (m
> 2 || m
< -1))
3023 se
->expr
= gfc_build_const (type
, integer_one_node
);
3027 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3028 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3030 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3031 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3032 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3033 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3036 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3039 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3040 logical_type_node
, tmp
, cond
);
3041 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3042 tmp
, build_int_cst (type
, 1),
3043 build_int_cst (type
, 0));
3047 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3048 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3049 build_int_cst (type
, -1),
3050 build_int_cst (type
, 0));
3051 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3052 cond
, build_int_cst (type
, 1), tmp
);
3056 memset (vartmp
, 0, sizeof (vartmp
));
3060 tmp
= gfc_build_const (type
, integer_one_node
);
3061 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3065 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3071 /* Power op (**). Constant integer exponent has special handling. */
3074 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3076 tree gfc_int4_type_node
;
3079 int res_ikind_1
, res_ikind_2
;
3084 gfc_init_se (&lse
, se
);
3085 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3086 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3087 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3089 gfc_init_se (&rse
, se
);
3090 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3091 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3093 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3094 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3095 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3098 if (INTEGER_CST_P (lse
.expr
)
3099 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3101 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3103 int kind
, ikind
, bit_size
;
3105 v
= wlhs
.to_shwi ();
3108 kind
= expr
->value
.op
.op1
->ts
.kind
;
3109 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3110 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3114 /* 1**something is always 1. */
3115 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3120 /* (-1)**n is 1 - ((n & 1) << 1) */
3124 type
= TREE_TYPE (lse
.expr
);
3125 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3126 rse
.expr
, build_int_cst (type
, 1));
3127 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3128 tmp
, build_int_cst (type
, 1));
3129 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3130 build_int_cst (type
, 1), tmp
);
3134 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3136 /* Here v is +/- 2**e. The further simplification uses
3137 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3138 1<<(4*n), etc., but we have to make sure to return zero
3139 if the number of bits is too large. */
3149 type
= TREE_TYPE (lse
.expr
);
3154 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3155 TREE_TYPE (rse
.expr
),
3156 rse
.expr
, rse
.expr
);
3159 /* use popcount for fast log2(w) */
3160 int e
= wi::popcount (w
-1);
3161 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3162 TREE_TYPE (rse
.expr
),
3163 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3167 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3168 build_int_cst (type
, 1), shift
);
3169 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3170 rse
.expr
, build_int_cst (type
, 0));
3171 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3172 build_int_cst (type
, 0));
3173 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3174 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3175 rse
.expr
, num_bits
);
3176 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3177 build_int_cst (type
, 0), cond
);
3184 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3186 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3187 rse
.expr
, build_int_cst (type
, 1));
3188 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3189 tmp2
, build_int_cst (type
, 1));
3190 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3191 build_int_cst (type
, 1), tmp2
);
3192 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3199 gfc_int4_type_node
= gfc_get_int_type (4);
3201 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3202 library routine. But in the end, we have to convert the result back
3203 if this case applies -- with res_ikind_K, we keep track whether operand K
3204 falls into this case. */
3208 kind
= expr
->value
.op
.op1
->ts
.kind
;
3209 switch (expr
->value
.op
.op2
->ts
.type
)
3212 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3217 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3218 res_ikind_2
= ikind
;
3240 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3242 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3269 switch (expr
->value
.op
.op1
->ts
.type
)
3272 if (kind
== 3) /* Case 16 was not handled properly above. */
3274 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3278 /* Use builtins for real ** int4. */
3284 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3288 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3292 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3296 /* Use the __builtin_powil() only if real(kind=16) is
3297 actually the C long double type. */
3298 if (!gfc_real16_is_float128
)
3299 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3307 /* If we don't have a good builtin for this, go for the
3308 library function. */
3310 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3314 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3323 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3327 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3335 se
->expr
= build_call_expr_loc (input_location
,
3336 fndecl
, 2, lse
.expr
, rse
.expr
);
3338 /* Convert the result back if it is of wrong integer kind. */
3339 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3341 /* We want the maximum of both operand kinds as result. */
3342 if (res_ikind_1
< res_ikind_2
)
3343 res_ikind_1
= res_ikind_2
;
3344 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3349 /* Generate code to allocate a string temporary. */
3352 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3357 if (gfc_can_put_var_on_stack (len
))
3359 /* Create a temporary variable to hold the result. */
3360 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3361 TREE_TYPE (len
), len
,
3362 build_int_cst (TREE_TYPE (len
), 1));
3363 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3365 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3366 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3368 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3370 var
= gfc_create_var (tmp
, "str");
3371 var
= gfc_build_addr_expr (type
, var
);
3375 /* Allocate a temporary to hold the result. */
3376 var
= gfc_create_var (type
, "pstr");
3377 gcc_assert (POINTER_TYPE_P (type
));
3378 tmp
= TREE_TYPE (type
);
3379 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3380 tmp
= TREE_TYPE (tmp
);
3381 tmp
= TYPE_SIZE_UNIT (tmp
);
3382 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3383 fold_convert (size_type_node
, len
),
3384 fold_convert (size_type_node
, tmp
));
3385 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3386 gfc_add_modify (&se
->pre
, var
, tmp
);
3388 /* Free the temporary afterwards. */
3389 tmp
= gfc_call_free (var
);
3390 gfc_add_expr_to_block (&se
->post
, tmp
);
3397 /* Handle a string concatenation operation. A temporary will be allocated to
3401 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3404 tree len
, type
, var
, tmp
, fndecl
;
3406 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3407 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3408 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3410 gfc_init_se (&lse
, se
);
3411 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3412 gfc_conv_string_parameter (&lse
);
3413 gfc_init_se (&rse
, se
);
3414 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3415 gfc_conv_string_parameter (&rse
);
3417 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3418 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3420 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3421 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3422 if (len
== NULL_TREE
)
3424 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3425 gfc_charlen_type_node
,
3426 fold_convert (gfc_charlen_type_node
,
3428 fold_convert (gfc_charlen_type_node
,
3429 rse
.string_length
));
3432 type
= build_pointer_type (type
);
3434 var
= gfc_conv_string_tmp (se
, type
, len
);
3436 /* Do the actual concatenation. */
3437 if (expr
->ts
.kind
== 1)
3438 fndecl
= gfor_fndecl_concat_string
;
3439 else if (expr
->ts
.kind
== 4)
3440 fndecl
= gfor_fndecl_concat_string_char4
;
3444 tmp
= build_call_expr_loc (input_location
,
3445 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3446 rse
.string_length
, rse
.expr
);
3447 gfc_add_expr_to_block (&se
->pre
, tmp
);
3449 /* Add the cleanup for the operands. */
3450 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3451 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3454 se
->string_length
= len
;
3457 /* Translates an op expression. Common (binary) cases are handled by this
3458 function, others are passed on. Recursion is used in either case.
3459 We use the fact that (op1.ts == op2.ts) (except for the power
3461 Operators need no special handling for scalarized expressions as long as
3462 they call gfc_conv_simple_val to get their operands.
3463 Character strings get special handling. */
3466 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3468 enum tree_code code
;
3477 switch (expr
->value
.op
.op
)
3479 case INTRINSIC_PARENTHESES
:
3480 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3481 && flag_protect_parens
)
3483 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3484 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3489 case INTRINSIC_UPLUS
:
3490 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3493 case INTRINSIC_UMINUS
:
3494 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3498 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3501 case INTRINSIC_PLUS
:
3505 case INTRINSIC_MINUS
:
3509 case INTRINSIC_TIMES
:
3513 case INTRINSIC_DIVIDE
:
3514 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3515 an integer, we must round towards zero, so we use a
3517 if (expr
->ts
.type
== BT_INTEGER
)
3518 code
= TRUNC_DIV_EXPR
;
3523 case INTRINSIC_POWER
:
3524 gfc_conv_power_op (se
, expr
);
3527 case INTRINSIC_CONCAT
:
3528 gfc_conv_concat_op (se
, expr
);
3532 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3537 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3541 /* EQV and NEQV only work on logicals, but since we represent them
3542 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3544 case INTRINSIC_EQ_OS
:
3552 case INTRINSIC_NE_OS
:
3553 case INTRINSIC_NEQV
:
3560 case INTRINSIC_GT_OS
:
3567 case INTRINSIC_GE_OS
:
3574 case INTRINSIC_LT_OS
:
3581 case INTRINSIC_LE_OS
:
3587 case INTRINSIC_USER
:
3588 case INTRINSIC_ASSIGN
:
3589 /* These should be converted into function calls by the frontend. */
3593 fatal_error (input_location
, "Unknown intrinsic op");
3597 /* The only exception to this is **, which is handled separately anyway. */
3598 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3600 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3604 gfc_init_se (&lse
, se
);
3605 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3606 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3609 gfc_init_se (&rse
, se
);
3610 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3611 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3615 gfc_conv_string_parameter (&lse
);
3616 gfc_conv_string_parameter (&rse
);
3618 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3619 rse
.string_length
, rse
.expr
,
3620 expr
->value
.op
.op1
->ts
.kind
,
3622 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3623 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3626 type
= gfc_typenode_for_spec (&expr
->ts
);
3630 /* The result of logical ops is always logical_type_node. */
3631 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3632 lse
.expr
, rse
.expr
);
3633 se
->expr
= convert (type
, tmp
);
3636 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3638 /* Add the post blocks. */
3639 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3640 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3643 /* If a string's length is one, we convert it to a single character. */
3646 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3650 || !tree_fits_uhwi_p (len
)
3651 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3654 if (TREE_INT_CST_LOW (len
) == 1)
3656 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3657 return build_fold_indirect_ref_loc (input_location
, str
);
3661 && TREE_CODE (str
) == ADDR_EXPR
3662 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3663 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3664 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3665 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3666 && TREE_INT_CST_LOW (len
) > 1
3667 && TREE_INT_CST_LOW (len
)
3668 == (unsigned HOST_WIDE_INT
)
3669 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3671 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3672 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3673 if (TREE_CODE (ret
) == INTEGER_CST
)
3675 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3676 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3677 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3679 for (i
= 1; i
< length
; i
++)
3692 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3695 if (sym
->backend_decl
)
3697 /* This becomes the nominal_type in
3698 function.c:assign_parm_find_data_types. */
3699 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3700 /* This becomes the passed_type in
3701 function.c:assign_parm_find_data_types. C promotes char to
3702 integer for argument passing. */
3703 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3705 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3710 /* If we have a constant character expression, make it into an
3712 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3717 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3718 (int)(*expr
)->value
.character
.string
[0]);
3719 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3721 /* The expr needs to be compatible with a C int. If the
3722 conversion fails, then the 2 causes an ICE. */
3723 ts
.type
= BT_INTEGER
;
3724 ts
.kind
= gfc_c_int_kind
;
3725 gfc_convert_type (*expr
, &ts
, 2);
3728 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3730 if ((*expr
)->ref
== NULL
)
3732 se
->expr
= gfc_string_to_single_character
3733 (build_int_cst (integer_type_node
, 1),
3734 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3736 ((*expr
)->symtree
->n
.sym
)),
3741 gfc_conv_variable (se
, *expr
);
3742 se
->expr
= gfc_string_to_single_character
3743 (build_int_cst (integer_type_node
, 1),
3744 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3752 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3753 if STR is a string literal, otherwise return -1. */
3756 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3759 && TREE_CODE (str
) == ADDR_EXPR
3760 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3761 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3762 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3763 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3764 && tree_fits_uhwi_p (len
)
3765 && tree_to_uhwi (len
) >= 1
3766 && tree_to_uhwi (len
)
3767 == (unsigned HOST_WIDE_INT
)
3768 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3770 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3771 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3772 if (TREE_CODE (folded
) == INTEGER_CST
)
3774 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3775 int length
= TREE_STRING_LENGTH (string_cst
);
3776 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3778 for (; length
> 0; length
--)
3779 if (ptr
[length
- 1] != ' ')
3788 /* Helper to build a call to memcmp. */
3791 build_memcmp_call (tree s1
, tree s2
, tree n
)
3795 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3796 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3798 s1
= fold_convert (pvoid_type_node
, s1
);
3800 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3801 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3803 s2
= fold_convert (pvoid_type_node
, s2
);
3805 n
= fold_convert (size_type_node
, n
);
3807 tmp
= build_call_expr_loc (input_location
,
3808 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3811 return fold_convert (integer_type_node
, tmp
);
3814 /* Compare two strings. If they are all single characters, the result is the
3815 subtraction of them. Otherwise, we build a library call. */
3818 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3819 enum tree_code code
)
3825 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3826 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3828 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3829 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3831 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3833 /* Deal with single character specially. */
3834 sc1
= fold_convert (integer_type_node
, sc1
);
3835 sc2
= fold_convert (integer_type_node
, sc2
);
3836 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3840 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3842 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3844 /* If one string is a string literal with LEN_TRIM longer
3845 than the length of the second string, the strings
3847 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3848 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3849 return integer_one_node
;
3850 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3851 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3852 return integer_one_node
;
3855 /* We can compare via memcpy if the strings are known to be equal
3856 in length and they are
3858 - kind=4 and the comparison is for (in)equality. */
3860 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3861 && tree_int_cst_equal (len1
, len2
)
3862 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3867 chartype
= gfc_get_char_type (kind
);
3868 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3869 fold_convert (TREE_TYPE(len1
),
3870 TYPE_SIZE_UNIT(chartype
)),
3872 return build_memcmp_call (str1
, str2
, tmp
);
3875 /* Build a call for the comparison. */
3877 fndecl
= gfor_fndecl_compare_string
;
3879 fndecl
= gfor_fndecl_compare_string_char4
;
3883 return build_call_expr_loc (input_location
, fndecl
, 4,
3884 len1
, str1
, len2
, str2
);
3888 /* Return the backend_decl for a procedure pointer component. */
3891 get_proc_ptr_comp (gfc_expr
*e
)
3897 gfc_init_se (&comp_se
, NULL
);
3898 e2
= gfc_copy_expr (e
);
3899 /* We have to restore the expr type later so that gfc_free_expr frees
3900 the exact same thing that was allocated.
3901 TODO: This is ugly. */
3902 old_type
= e2
->expr_type
;
3903 e2
->expr_type
= EXPR_VARIABLE
;
3904 gfc_conv_expr (&comp_se
, e2
);
3905 e2
->expr_type
= old_type
;
3907 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3911 /* Convert a typebound function reference from a class object. */
3913 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3918 if (!VAR_P (base_object
))
3920 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3921 gfc_add_modify (&se
->pre
, var
, base_object
);
3923 se
->expr
= gfc_class_vptr_get (base_object
);
3924 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3926 while (ref
&& ref
->next
)
3928 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3929 if (ref
->u
.c
.sym
->attr
.extension
)
3930 conv_parent_component_references (se
, ref
);
3931 gfc_conv_component_ref (se
, ref
);
3932 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3937 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
3938 gfc_actual_arglist
*actual_args
)
3942 if (gfc_is_proc_ptr_comp (expr
))
3943 tmp
= get_proc_ptr_comp (expr
);
3944 else if (sym
->attr
.dummy
)
3946 tmp
= gfc_get_symbol_decl (sym
);
3947 if (sym
->attr
.proc_pointer
)
3948 tmp
= build_fold_indirect_ref_loc (input_location
,
3950 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3951 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3955 if (!sym
->backend_decl
)
3956 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
3958 TREE_USED (sym
->backend_decl
) = 1;
3960 tmp
= sym
->backend_decl
;
3962 if (sym
->attr
.cray_pointee
)
3964 /* TODO - make the cray pointee a pointer to a procedure,
3965 assign the pointer to it and use it for the call. This
3967 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3968 gfc_get_symbol_decl (sym
->cp_pointer
));
3969 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3972 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3974 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3975 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3982 /* Initialize MAPPING. */
3985 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3987 mapping
->syms
= NULL
;
3988 mapping
->charlens
= NULL
;
3992 /* Free all memory held by MAPPING (but not MAPPING itself). */
3995 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3997 gfc_interface_sym_mapping
*sym
;
3998 gfc_interface_sym_mapping
*nextsym
;
4000 gfc_charlen
*nextcl
;
4002 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4004 nextsym
= sym
->next
;
4005 sym
->new_sym
->n
.sym
->formal
= NULL
;
4006 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4007 gfc_free_expr (sym
->expr
);
4008 free (sym
->new_sym
);
4011 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4014 gfc_free_expr (cl
->length
);
4020 /* Return a copy of gfc_charlen CL. Add the returned structure to
4021 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4023 static gfc_charlen
*
4024 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4027 gfc_charlen
*new_charlen
;
4029 new_charlen
= gfc_get_charlen ();
4030 new_charlen
->next
= mapping
->charlens
;
4031 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4033 mapping
->charlens
= new_charlen
;
4038 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4039 array variable that can be used as the actual argument for dummy
4040 argument SYM. Add any initialization code to BLOCK. PACKED is as
4041 for gfc_get_nodesc_array_type and DATA points to the first element
4042 in the passed array. */
4045 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4046 gfc_packed packed
, tree data
)
4051 type
= gfc_typenode_for_spec (&sym
->ts
);
4052 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4053 !sym
->attr
.target
&& !sym
->attr
.pointer
4054 && !sym
->attr
.proc_pointer
);
4056 var
= gfc_create_var (type
, "ifm");
4057 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4063 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4064 and offset of descriptorless array type TYPE given that it has the same
4065 size as DESC. Add any set-up code to BLOCK. */
4068 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4075 offset
= gfc_index_zero_node
;
4076 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4078 dim
= gfc_rank_cst
[n
];
4079 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4080 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4082 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4083 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4084 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4085 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4087 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4089 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4090 gfc_array_index_type
,
4091 gfc_conv_descriptor_ubound_get (desc
, dim
),
4092 gfc_conv_descriptor_lbound_get (desc
, dim
));
4093 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4094 gfc_array_index_type
,
4095 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4096 tmp
= gfc_evaluate_now (tmp
, block
);
4097 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4099 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4100 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4101 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4102 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4103 gfc_array_index_type
, offset
, tmp
);
4105 offset
= gfc_evaluate_now (offset
, block
);
4106 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4110 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4111 in SE. The caller may still use se->expr and se->string_length after
4112 calling this function. */
4115 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4116 gfc_symbol
* sym
, gfc_se
* se
,
4119 gfc_interface_sym_mapping
*sm
;
4123 gfc_symbol
*new_sym
;
4125 gfc_symtree
*new_symtree
;
4127 /* Create a new symbol to represent the actual argument. */
4128 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4129 new_sym
->ts
= sym
->ts
;
4130 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4131 new_sym
->attr
.referenced
= 1;
4132 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4133 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4134 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4135 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4136 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4137 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4138 new_sym
->attr
.function
= sym
->attr
.function
;
4140 /* Ensure that the interface is available and that
4141 descriptors are passed for array actual arguments. */
4142 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4144 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4145 new_sym
->attr
.always_explicit
4146 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4149 /* Create a fake symtree for it. */
4151 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4152 new_symtree
->n
.sym
= new_sym
;
4153 gcc_assert (new_symtree
== root
);
4155 /* Create a dummy->actual mapping. */
4156 sm
= XCNEW (gfc_interface_sym_mapping
);
4157 sm
->next
= mapping
->syms
;
4159 sm
->new_sym
= new_symtree
;
4160 sm
->expr
= gfc_copy_expr (expr
);
4163 /* Stabilize the argument's value. */
4164 if (!sym
->attr
.function
&& se
)
4165 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4167 if (sym
->ts
.type
== BT_CHARACTER
)
4169 /* Create a copy of the dummy argument's length. */
4170 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4171 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4173 /* If the length is specified as "*", record the length that
4174 the caller is passing. We should use the callee's length
4175 in all other cases. */
4176 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4178 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4179 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4186 /* Use the passed value as-is if the argument is a function. */
4187 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4190 /* If the argument is a pass-by-value scalar, use the value as is. */
4191 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4194 /* If the argument is either a string or a pointer to a string,
4195 convert it to a boundless character type. */
4196 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4198 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4199 tmp
= build_pointer_type (tmp
);
4200 if (sym
->attr
.pointer
)
4201 value
= build_fold_indirect_ref_loc (input_location
,
4205 value
= fold_convert (tmp
, value
);
4208 /* If the argument is a scalar, a pointer to an array or an allocatable,
4210 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4211 value
= build_fold_indirect_ref_loc (input_location
,
4214 /* For character(*), use the actual argument's descriptor. */
4215 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4216 value
= build_fold_indirect_ref_loc (input_location
,
4219 /* If the argument is an array descriptor, use it to determine
4220 information about the actual argument's shape. */
4221 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4222 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4224 /* Get the actual argument's descriptor. */
4225 desc
= build_fold_indirect_ref_loc (input_location
,
4228 /* Create the replacement variable. */
4229 tmp
= gfc_conv_descriptor_data_get (desc
);
4230 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4233 /* Use DESC to work out the upper bounds, strides and offset. */
4234 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4237 /* Otherwise we have a packed array. */
4238 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4239 PACKED_FULL
, se
->expr
);
4241 new_sym
->backend_decl
= value
;
4245 /* Called once all dummy argument mappings have been added to MAPPING,
4246 but before the mapping is used to evaluate expressions. Pre-evaluate
4247 the length of each argument, adding any initialization code to PRE and
4248 any finalization code to POST. */
4251 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4252 stmtblock_t
* pre
, stmtblock_t
* post
)
4254 gfc_interface_sym_mapping
*sym
;
4258 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4259 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4260 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4262 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4263 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4264 gfc_init_se (&se
, NULL
);
4265 gfc_conv_expr (&se
, expr
);
4266 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4267 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4268 gfc_add_block_to_block (pre
, &se
.pre
);
4269 gfc_add_block_to_block (post
, &se
.post
);
4271 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4276 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4280 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4281 gfc_constructor_base base
)
4284 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4286 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4289 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4290 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4291 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4297 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4301 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4306 for (; ref
; ref
= ref
->next
)
4310 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4312 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4313 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4314 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4323 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4324 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4330 /* Convert intrinsic function calls into result expressions. */
4333 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4341 arg1
= expr
->value
.function
.actual
->expr
;
4342 if (expr
->value
.function
.actual
->next
)
4343 arg2
= expr
->value
.function
.actual
->next
->expr
;
4347 sym
= arg1
->symtree
->n
.sym
;
4349 if (sym
->attr
.dummy
)
4354 switch (expr
->value
.function
.isym
->id
)
4357 /* TODO figure out why this condition is necessary. */
4358 if (sym
->attr
.function
4359 && (arg1
->ts
.u
.cl
->length
== NULL
4360 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4361 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4364 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4367 case GFC_ISYM_LEN_TRIM
:
4368 new_expr
= gfc_copy_expr (arg1
);
4369 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4374 gfc_replace_expr (arg1
, new_expr
);
4378 if (!sym
->as
|| sym
->as
->rank
== 0)
4381 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4383 dup
= mpz_get_si (arg2
->value
.integer
);
4388 dup
= sym
->as
->rank
;
4392 for (; d
< dup
; d
++)
4396 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4398 gfc_free_expr (new_expr
);
4402 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4403 gfc_get_int_expr (gfc_default_integer_kind
,
4405 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4407 new_expr
= gfc_multiply (new_expr
, tmp
);
4413 case GFC_ISYM_LBOUND
:
4414 case GFC_ISYM_UBOUND
:
4415 /* TODO These implementations of lbound and ubound do not limit if
4416 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4418 if (!sym
->as
|| sym
->as
->rank
== 0)
4421 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4422 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4426 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4428 if (sym
->as
->lower
[d
])
4429 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4433 if (sym
->as
->upper
[d
])
4434 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4442 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4446 gfc_replace_expr (expr
, new_expr
);
4452 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4453 gfc_interface_mapping
* mapping
)
4455 gfc_formal_arglist
*f
;
4456 gfc_actual_arglist
*actual
;
4458 actual
= expr
->value
.function
.actual
;
4459 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4461 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4466 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4469 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4474 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4476 for (d
= 0; d
< as
->rank
; d
++)
4478 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4479 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4482 expr
->value
.function
.esym
->as
= as
;
4485 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4487 expr
->value
.function
.esym
->ts
.u
.cl
->length
4488 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4490 gfc_apply_interface_mapping_to_expr (mapping
,
4491 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4496 /* EXPR is a copy of an expression that appeared in the interface
4497 associated with MAPPING. Walk it recursively looking for references to
4498 dummy arguments that MAPPING maps to actual arguments. Replace each such
4499 reference with a reference to the associated actual argument. */
4502 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4505 gfc_interface_sym_mapping
*sym
;
4506 gfc_actual_arglist
*actual
;
4511 /* Copying an expression does not copy its length, so do that here. */
4512 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4514 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4515 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4518 /* Apply the mapping to any references. */
4519 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4521 /* ...and to the expression's symbol, if it has one. */
4522 /* TODO Find out why the condition on expr->symtree had to be moved into
4523 the loop rather than being outside it, as originally. */
4524 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4525 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4527 if (sym
->new_sym
->n
.sym
->backend_decl
)
4528 expr
->symtree
= sym
->new_sym
;
4530 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4533 /* ...and to subexpressions in expr->value. */
4534 switch (expr
->expr_type
)
4539 case EXPR_SUBSTRING
:
4543 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4544 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4548 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4549 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4551 if (expr
->value
.function
.esym
== NULL
4552 && expr
->value
.function
.isym
!= NULL
4553 && expr
->value
.function
.actual
4554 && expr
->value
.function
.actual
->expr
4555 && expr
->value
.function
.actual
->expr
->symtree
4556 && gfc_map_intrinsic_function (expr
, mapping
))
4559 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4560 if (sym
->old
== expr
->value
.function
.esym
)
4562 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4563 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4564 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4569 case EXPR_STRUCTURE
:
4570 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4584 /* Evaluate interface expression EXPR using MAPPING. Store the result
4588 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4589 gfc_se
* se
, gfc_expr
* expr
)
4591 expr
= gfc_copy_expr (expr
);
4592 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4593 gfc_conv_expr (se
, expr
);
4594 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4595 gfc_free_expr (expr
);
4599 /* Returns a reference to a temporary array into which a component of
4600 an actual argument derived type array is copied and then returned
4601 after the function call. */
4603 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4604 sym_intent intent
, bool formal_ptr
,
4605 const gfc_symbol
*fsym
, const char *proc_name
,
4606 gfc_symbol
*sym
, bool check_contiguous
)
4614 gfc_array_info
*info
;
4627 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4629 if (pass_optional
|| check_contiguous
)
4631 gfc_init_se (&work_se
, NULL
);
4637 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4639 /* We will create a temporary array, so let us warn. */
4642 if (fsym
&& proc_name
)
4643 msg
= xasprintf ("An array temporary was created for argument "
4644 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4646 msg
= xasprintf ("An array temporary was created");
4648 tmp
= build_int_cst (logical_type_node
, 1);
4649 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4654 gfc_init_se (&lse
, NULL
);
4655 gfc_init_se (&rse
, NULL
);
4657 /* Walk the argument expression. */
4658 rss
= gfc_walk_expr (expr
);
4660 gcc_assert (rss
!= gfc_ss_terminator
);
4662 /* Initialize the scalarizer. */
4663 gfc_init_loopinfo (&loop
);
4664 gfc_add_ss_to_loop (&loop
, rss
);
4666 /* Calculate the bounds of the scalarization. */
4667 gfc_conv_ss_startstride (&loop
);
4669 /* Build an ss for the temporary. */
4670 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4671 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4673 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4674 if (GFC_ARRAY_TYPE_P (base_type
)
4675 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4676 base_type
= gfc_get_element_type (base_type
);
4678 if (expr
->ts
.type
== BT_CLASS
)
4679 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4681 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4682 ? expr
->ts
.u
.cl
->backend_decl
4686 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4688 /* Associate the SS with the loop. */
4689 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4691 /* Setup the scalarizing loops. */
4692 gfc_conv_loop_setup (&loop
, &expr
->where
);
4694 /* Pass the temporary descriptor back to the caller. */
4695 info
= &loop
.temp_ss
->info
->data
.array
;
4696 parmse
->expr
= info
->descriptor
;
4698 /* Setup the gfc_se structures. */
4699 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4700 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4703 lse
.ss
= loop
.temp_ss
;
4704 gfc_mark_ss_chain_used (rss
, 1);
4705 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4707 /* Start the scalarized loop body. */
4708 gfc_start_scalarized_body (&loop
, &body
);
4710 /* Translate the expression. */
4711 gfc_conv_expr (&rse
, expr
);
4713 /* Reset the offset for the function call since the loop
4714 is zero based on the data pointer. Note that the temp
4715 comes first in the loop chain since it is added second. */
4716 if (gfc_is_class_array_function (expr
))
4718 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4719 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4720 gfc_index_zero_node
);
4723 gfc_conv_tmp_array_ref (&lse
);
4725 if (intent
!= INTENT_OUT
)
4727 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4728 gfc_add_expr_to_block (&body
, tmp
);
4729 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4730 gfc_trans_scalarizing_loops (&loop
, &body
);
4734 /* Make sure that the temporary declaration survives by merging
4735 all the loop declarations into the current context. */
4736 for (n
= 0; n
< loop
.dimen
; n
++)
4738 gfc_merge_block_scope (&body
);
4739 body
= loop
.code
[loop
.order
[n
]];
4741 gfc_merge_block_scope (&body
);
4744 /* Add the post block after the second loop, so that any
4745 freeing of allocated memory is done at the right time. */
4746 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4748 /**********Copy the temporary back again.*********/
4750 gfc_init_se (&lse
, NULL
);
4751 gfc_init_se (&rse
, NULL
);
4753 /* Walk the argument expression. */
4754 lss
= gfc_walk_expr (expr
);
4755 rse
.ss
= loop
.temp_ss
;
4758 /* Initialize the scalarizer. */
4759 gfc_init_loopinfo (&loop2
);
4760 gfc_add_ss_to_loop (&loop2
, lss
);
4762 dimen
= rse
.ss
->dimen
;
4764 /* Skip the write-out loop for this case. */
4765 if (gfc_is_class_array_function (expr
))
4766 goto class_array_fcn
;
4768 /* Calculate the bounds of the scalarization. */
4769 gfc_conv_ss_startstride (&loop2
);
4771 /* Setup the scalarizing loops. */
4772 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4774 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4775 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4777 gfc_mark_ss_chain_used (lss
, 1);
4778 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4780 /* Declare the variable to hold the temporary offset and start the
4781 scalarized loop body. */
4782 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4783 gfc_start_scalarized_body (&loop2
, &body
);
4785 /* Build the offsets for the temporary from the loop variables. The
4786 temporary array has lbounds of zero and strides of one in all
4787 dimensions, so this is very simple. The offset is only computed
4788 outside the innermost loop, so the overall transfer could be
4789 optimized further. */
4790 info
= &rse
.ss
->info
->data
.array
;
4792 tmp_index
= gfc_index_zero_node
;
4793 for (n
= dimen
- 1; n
> 0; n
--)
4796 tmp
= rse
.loop
->loopvar
[n
];
4797 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4798 tmp
, rse
.loop
->from
[n
]);
4799 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4802 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4803 gfc_array_index_type
,
4804 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4805 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4806 gfc_array_index_type
,
4807 tmp_str
, gfc_index_one_node
);
4809 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4810 gfc_array_index_type
, tmp
, tmp_str
);
4813 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4814 gfc_array_index_type
,
4815 tmp_index
, rse
.loop
->from
[0]);
4816 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4818 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4819 gfc_array_index_type
,
4820 rse
.loop
->loopvar
[0], offset
);
4822 /* Now use the offset for the reference. */
4823 tmp
= build_fold_indirect_ref_loc (input_location
,
4825 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4827 if (expr
->ts
.type
== BT_CHARACTER
)
4828 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4830 gfc_conv_expr (&lse
, expr
);
4832 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4834 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4835 gfc_add_expr_to_block (&body
, tmp
);
4837 /* Generate the copying loops. */
4838 gfc_trans_scalarizing_loops (&loop2
, &body
);
4840 /* Wrap the whole thing up by adding the second loop to the post-block
4841 and following it by the post-block of the first loop. In this way,
4842 if the temporary needs freeing, it is done after use! */
4843 if (intent
!= INTENT_IN
)
4845 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4846 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4851 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4853 gfc_cleanup_loop (&loop
);
4854 gfc_cleanup_loop (&loop2
);
4856 /* Pass the string length to the argument expression. */
4857 if (expr
->ts
.type
== BT_CHARACTER
)
4858 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4860 /* Determine the offset for pointer formal arguments and set the
4864 size
= gfc_index_one_node
;
4865 offset
= gfc_index_zero_node
;
4866 for (n
= 0; n
< dimen
; n
++)
4868 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4870 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4871 gfc_array_index_type
, tmp
,
4872 gfc_index_one_node
);
4873 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4877 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4880 gfc_index_one_node
);
4881 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4882 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4883 gfc_array_index_type
,
4885 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4886 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4887 gfc_array_index_type
,
4888 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4889 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4890 gfc_array_index_type
,
4891 tmp
, gfc_index_one_node
);
4892 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4893 gfc_array_index_type
, size
, tmp
);
4896 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4900 /* We want either the address for the data or the address of the descriptor,
4901 depending on the mode of passing array arguments. */
4903 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4905 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4907 /* Basically make this into
4918 pointer = parmse->expr;
4925 if (present && !contiguous)
4930 if (pass_optional
|| check_contiguous
)
4933 stmtblock_t else_block
;
4934 tree pre_stmts
, post_stmts
;
4937 tree present_var
= NULL_TREE
;
4938 tree cont_var
= NULL_TREE
;
4941 type
= TREE_TYPE (parmse
->expr
);
4942 pointer
= gfc_create_var (type
, "arg_ptr");
4944 if (check_contiguous
)
4946 gfc_se cont_se
, array_se
;
4947 stmtblock_t if_block
, else_block
;
4948 tree if_stmt
, else_stmt
;
4952 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
4954 /* If the size is known to be one at compile-time, set
4955 cont_var to true unconditionally. This may look
4956 inelegant, but we're only doing this during
4957 optimization, so the statements will be optimized away,
4958 and this saves complexity here. */
4960 size_set
= gfc_array_size (expr
, &size
);
4961 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
4963 gfc_add_modify (&se
->pre
, cont_var
,
4964 build_one_cst (boolean_type_node
));
4968 /* cont_var = is_contiguous (expr); . */
4969 gfc_init_se (&cont_se
, parmse
);
4970 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
4971 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
4972 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
4973 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
4979 /* arrayse->expr = descriptor of a. */
4980 gfc_init_se (&array_se
, se
);
4981 gfc_conv_expr_descriptor (&array_se
, expr
);
4982 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
4983 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
4985 /* if_stmt = { pointer = &a[0]; } . */
4986 gfc_init_block (&if_block
);
4987 tmp
= gfc_conv_array_data (array_se
.expr
);
4988 tmp
= fold_convert (type
, tmp
);
4989 gfc_add_modify (&if_block
, pointer
, tmp
);
4990 if_stmt
= gfc_finish_block (&if_block
);
4992 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
4993 gfc_init_block (&else_block
);
4994 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
4995 gfc_add_modify (&else_block
, pointer
, parmse
->expr
);
4996 else_stmt
= gfc_finish_block (&else_block
);
4998 /* And put the above into an if statement. */
4999 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5000 gfc_likely (cont_var
,
5001 PRED_FORTRAN_CONTIGUOUS
),
5002 if_stmt
, else_stmt
);
5006 /* pointer = pramse->expr; . */
5007 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5008 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5013 present_var
= gfc_create_var (boolean_type_node
, "present");
5015 /* present_var = present(sym); . */
5016 tmp
= gfc_conv_expr_present (sym
);
5017 tmp
= fold_convert (boolean_type_node
, tmp
);
5018 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5020 /* else_stmt = { pointer = NULL; } . */
5021 gfc_init_block (&else_block
);
5022 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5023 else_stmt
= gfc_finish_block (&else_block
);
5025 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5026 gfc_likely (present_var
,
5027 PRED_FORTRAN_ABSENT_DUMMY
),
5028 pre_stmts
, else_stmt
);
5029 gfc_add_expr_to_block (&se
->pre
, tmp
);
5032 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5034 post_stmts
= gfc_finish_block (&parmse
->post
);
5036 /* Put together the post stuff, plus the optional
5038 if (check_contiguous
)
5041 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5043 build_zero_cst (boolean_type_node
));
5044 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5048 tree present_likely
= gfc_likely (present_var
,
5049 PRED_FORTRAN_ABSENT_DUMMY
);
5050 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5051 boolean_type_node
, present_likely
,
5059 gcc_assert (pass_optional
);
5060 post_cond
= present_var
;
5063 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5064 post_stmts
, build_empty_stmt (input_location
));
5065 gfc_add_expr_to_block (&se
->post
, tmp
);
5073 /* Generate the code for argument list functions. */
5076 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5078 /* Pass by value for g77 %VAL(arg), pass the address
5079 indirectly for %LOC, else by reference. Thus %REF
5080 is a "do-nothing" and %LOC is the same as an F95
5082 if (strcmp (name
, "%VAL") == 0)
5083 gfc_conv_expr (se
, expr
);
5084 else if (strcmp (name
, "%LOC") == 0)
5086 gfc_conv_expr_reference (se
, expr
);
5087 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5089 else if (strcmp (name
, "%REF") == 0)
5090 gfc_conv_expr_reference (se
, expr
);
5092 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5096 /* This function tells whether the middle-end representation of the expression
5097 E given as input may point to data otherwise accessible through a variable
5099 It is assumed that the only expressions that may alias are variables,
5100 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5102 This function is used to decide whether freeing an expression's allocatable
5103 components is safe or should be avoided.
5105 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5106 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5107 is necessary because for array constructors, aliasing depends on how
5109 - If E is an array constructor used as argument to an elemental procedure,
5110 the array, which is generated through shallow copy by the scalarizer,
5111 is used directly and can alias the expressions it was copied from.
5112 - If E is an array constructor used as argument to a non-elemental
5113 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5114 the array as in the previous case, but then that array is used
5115 to initialize a new descriptor through deep copy. There is no alias
5116 possible in that case.
5117 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5121 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5125 if (e
->expr_type
== EXPR_VARIABLE
)
5127 else if (e
->expr_type
== EXPR_FUNCTION
)
5129 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5131 if (proc_ifc
->result
!= NULL
5132 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5133 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5134 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5135 || proc_ifc
->result
->attr
.pointer
))
5140 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5143 for (c
= gfc_constructor_first (e
->value
.constructor
);
5144 c
; c
= gfc_constructor_next (c
))
5146 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5153 /* A helper function to set the dtype for unallocated or unassociated
5157 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5165 /* TODO Figure out how to handle optional dummies. */
5166 if (e
&& e
->expr_type
== EXPR_VARIABLE
5167 && e
->symtree
->n
.sym
->attr
.optional
)
5170 desc
= parmse
->expr
;
5171 if (desc
== NULL_TREE
)
5174 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5175 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5177 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5180 gfc_init_block (&block
);
5181 tmp
= gfc_conv_descriptor_data_get (desc
);
5182 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5183 logical_type_node
, tmp
,
5184 build_int_cst (TREE_TYPE (tmp
), 0));
5185 tmp
= gfc_conv_descriptor_dtype (desc
);
5186 type
= gfc_get_element_type (TREE_TYPE (desc
));
5187 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5188 TREE_TYPE (tmp
), tmp
,
5189 gfc_get_dtype_rank_type (e
->rank
, type
));
5190 gfc_add_expr_to_block (&block
, tmp
);
5191 cond
= build3_v (COND_EXPR
, cond
,
5192 gfc_finish_block (&block
),
5193 build_empty_stmt (input_location
));
5194 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5199 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5200 ISO_Fortran_binding array descriptors. */
5203 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5213 symbol_attribute attr
= gfc_expr_attr (e
);
5215 /* If this is a full array or a scalar, the allocatable and pointer
5216 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5218 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
5222 else if (attr
.allocatable
)
5226 /* If the formal argument is assumed shape and neither a pointer nor
5227 allocatable, it is unconditionally CFI_attribute_other. */
5228 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
5229 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)
5232 cfi_attribute
= attribute
;
5236 parmse
->force_no_tmp
= 1;
5237 if (fsym
->attr
.contiguous
5238 && !gfc_is_simply_contiguous (e
, false, true))
5239 gfc_conv_subref_array_arg (parmse
, e
, false, fsym
->attr
.intent
,
5240 fsym
->attr
.pointer
);
5242 gfc_conv_expr_descriptor (parmse
, e
);
5244 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5245 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5247 bool is_artificial
= (INDIRECT_REF_P (parmse
->expr
)
5248 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse
->expr
, 0))
5249 : DECL_ARTIFICIAL (parmse
->expr
));
5251 /* Unallocated allocatable arrays and unassociated pointer arrays
5252 need their dtype setting if they are argument associated with
5253 assumed rank dummies. */
5254 if (fsym
&& fsym
->as
5255 && (gfc_expr_attr (e
).pointer
5256 || gfc_expr_attr (e
).allocatable
))
5257 set_dtype_for_unallocated (parmse
, e
);
5259 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5260 the expression type is different from the descriptor type, then
5261 the offset must be found (eg. to a component ref or substring)
5262 and the dtype updated. Assumed type entities are only allowed
5263 to be dummies in Fortran. They therefore lack the decl specific
5264 appendiges and so must be treated differently from other fortran
5265 entities passed to CFI descriptors in the interface decl. */
5266 type
= e
->ts
.type
!= BT_ASSUMED
? gfc_typenode_for_spec (&e
->ts
) :
5269 if (type
&& is_artificial
5270 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
5272 /* Obtain the offset to the data. */
5273 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
5274 gfc_index_zero_node
, true, e
);
5276 /* Update the dtype. */
5277 gfc_add_modify (&parmse
->pre
,
5278 gfc_conv_descriptor_dtype (parmse
->expr
),
5279 gfc_get_dtype_rank_type (e
->rank
, type
));
5281 else if (type
== NULL_TREE
5282 || (!is_subref_array (e
) && !is_artificial
))
5284 /* Make sure that the span is set for expressions where it
5285 might not have been done already. */
5286 tmp
= gfc_conv_descriptor_elem_len (parmse
->expr
);
5287 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5288 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
5293 gfc_conv_expr (parmse
, e
);
5295 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5296 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5299 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
5300 parmse
->expr
, attr
);
5303 /* Set the CFI attribute field through a temporary value for the
5305 desc_attr
= gfc_conv_descriptor_attribute (parmse
->expr
);
5306 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5307 void_type_node
, desc_attr
,
5308 build_int_cst (TREE_TYPE (desc_attr
), cfi_attribute
));
5309 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5311 /* Now pass the gfc_descriptor by reference. */
5312 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5314 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5315 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5316 gfc_desc_ptr
= parmse
->expr
;
5317 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
5318 gfc_add_modify (&parmse
->pre
, cfi_desc_ptr
, null_pointer_node
);
5320 /* Allocate the CFI descriptor itself and fill the fields. */
5321 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
5322 tmp
= build_call_expr_loc (input_location
,
5323 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
5324 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5326 /* Now set the gfc descriptor attribute. */
5327 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5328 void_type_node
, desc_attr
,
5329 build_int_cst (TREE_TYPE (desc_attr
), attribute
));
5330 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5332 /* The CFI descriptor is passed to the bind_C procedure. */
5333 parmse
->expr
= cfi_desc_ptr
;
5335 /* Free the CFI descriptor. */
5336 tmp
= gfc_call_free (cfi_desc_ptr
);
5337 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5339 /* Transfer values back to gfc descriptor. */
5340 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5341 tmp
= build_call_expr_loc (input_location
,
5342 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
5343 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5345 /* Deal with an optional dummy being passed to an optional formal arg
5346 by finishing the pre and post blocks and making their execution
5347 conditional on the dummy being present. */
5348 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5349 && e
->symtree
->n
.sym
->attr
.optional
)
5351 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5352 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5354 build_int_cst (pvoid_type_node
, 0));
5355 tmp
= build3_v (COND_EXPR
, cond
,
5356 gfc_finish_block (&parmse
->pre
), tmp
);
5357 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5358 tmp
= build3_v (COND_EXPR
, cond
,
5359 gfc_finish_block (&parmse
->post
),
5360 build_empty_stmt (input_location
));
5361 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5366 /* Generate code for a procedure call. Note can return se->post != NULL.
5367 If se->direct_byref is set then se->expr contains the return parameter.
5368 Return nonzero, if the call has alternate specifiers.
5369 'expr' is only needed for procedure pointer components. */
5372 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5373 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5374 vec
<tree
, va_gc
> *append_args
)
5376 gfc_interface_mapping mapping
;
5377 vec
<tree
, va_gc
> *arglist
;
5378 vec
<tree
, va_gc
> *retargs
;
5382 gfc_array_info
*info
;
5389 vec
<tree
, va_gc
> *stringargs
;
5390 vec
<tree
, va_gc
> *optionalargs
;
5392 gfc_formal_arglist
*formal
;
5393 gfc_actual_arglist
*arg
;
5394 int has_alternate_specifier
= 0;
5395 bool need_interface_mapping
;
5403 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5404 gfc_component
*comp
= NULL
;
5411 optionalargs
= NULL
;
5416 comp
= gfc_get_proc_ptr_comp (expr
);
5418 bool elemental_proc
= (comp
5419 && comp
->ts
.interface
5420 && comp
->ts
.interface
->attr
.elemental
)
5421 || (comp
&& comp
->attr
.elemental
)
5422 || sym
->attr
.elemental
;
5426 if (!elemental_proc
)
5428 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5429 if (se
->ss
->info
->useflags
)
5431 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5432 && sym
->result
->attr
.dimension
)
5433 || (comp
&& comp
->attr
.dimension
)
5434 || gfc_is_class_array_function (expr
));
5435 gcc_assert (se
->loop
!= NULL
);
5436 /* Access the previously obtained result. */
5437 gfc_conv_tmp_array_ref (se
);
5441 info
= &se
->ss
->info
->data
.array
;
5446 gfc_init_block (&post
);
5447 gfc_init_interface_mapping (&mapping
);
5450 formal
= gfc_sym_get_dummy_args (sym
);
5451 need_interface_mapping
= sym
->attr
.dimension
||
5452 (sym
->ts
.type
== BT_CHARACTER
5453 && sym
->ts
.u
.cl
->length
5454 && sym
->ts
.u
.cl
->length
->expr_type
5459 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5460 need_interface_mapping
= comp
->attr
.dimension
||
5461 (comp
->ts
.type
== BT_CHARACTER
5462 && comp
->ts
.u
.cl
->length
5463 && comp
->ts
.u
.cl
->length
->expr_type
5467 base_object
= NULL_TREE
;
5468 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5469 is the third and fourth argument to such a function call a value
5470 denoting the number of elements to copy (i.e., most of the time the
5471 length of a deferred length string). */
5472 ulim_copy
= (formal
== NULL
)
5473 && UNLIMITED_POLY (sym
)
5474 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5476 /* Evaluate the arguments. */
5477 for (arg
= args
, argc
= 0; arg
!= NULL
;
5478 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5480 bool finalized
= false;
5481 bool non_unity_length_string
= false;
5484 fsym
= formal
? formal
->sym
: NULL
;
5485 parm_kind
= MISSING
;
5487 if (fsym
&& fsym
->ts
.type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
5488 && (!fsym
->ts
.u
.cl
->length
5489 || fsym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5490 || mpz_cmp_si (fsym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5491 non_unity_length_string
= true;
5493 /* If the procedure requires an explicit interface, the actual
5494 argument is passed according to the corresponding formal
5495 argument. If the corresponding formal argument is a POINTER,
5496 ALLOCATABLE or assumed shape, we do not use g77's calling
5497 convention, and pass the address of the array descriptor
5498 instead. Otherwise we use g77's calling convention, in other words
5499 pass the array data pointer without descriptor. */
5500 bool nodesc_arg
= fsym
!= NULL
5501 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5503 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5504 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5506 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5508 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5510 /* Class array expressions are sometimes coming completely unadorned
5511 with either arrayspec or _data component. Correct that here.
5512 OOP-TODO: Move this to the frontend. */
5513 if (e
&& e
->expr_type
== EXPR_VARIABLE
5515 && e
->ts
.type
== BT_CLASS
5516 && (CLASS_DATA (e
)->attr
.codimension
5517 || CLASS_DATA (e
)->attr
.dimension
))
5519 gfc_typespec temp_ts
= e
->ts
;
5520 gfc_add_class_array_ref (e
);
5526 if (se
->ignore_optional
)
5528 /* Some intrinsics have already been resolved to the correct
5532 else if (arg
->label
)
5534 has_alternate_specifier
= 1;
5539 gfc_init_se (&parmse
, NULL
);
5541 /* For scalar arguments with VALUE attribute which are passed by
5542 value, pass "0" and a hidden argument gives the optional
5544 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5545 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5546 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5548 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5550 vec_safe_push (optionalargs
, boolean_false_node
);
5554 /* Pass a NULL pointer for an absent arg. */
5555 parmse
.expr
= null_pointer_node
;
5556 if (arg
->missing_arg_type
== BT_CHARACTER
)
5557 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5562 else if (arg
->expr
->expr_type
== EXPR_NULL
5563 && fsym
&& !fsym
->attr
.pointer
5564 && (fsym
->ts
.type
!= BT_CLASS
5565 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5567 /* Pass a NULL pointer to denote an absent arg. */
5568 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5569 && (fsym
->ts
.type
!= BT_CLASS
5570 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5571 gfc_init_se (&parmse
, NULL
);
5572 parmse
.expr
= null_pointer_node
;
5573 if (arg
->missing_arg_type
== BT_CHARACTER
)
5574 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5576 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5577 && e
->ts
.type
== BT_DERIVED
)
5579 /* The derived type needs to be converted to a temporary
5581 gfc_init_se (&parmse
, se
);
5582 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5584 && e
->expr_type
== EXPR_VARIABLE
5585 && e
->symtree
->n
.sym
->attr
.optional
,
5586 CLASS_DATA (fsym
)->attr
.class_pointer
5587 || CLASS_DATA (fsym
)->attr
.allocatable
);
5589 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
5591 /* The intrinsic type needs to be converted to a temporary
5592 CLASS object for the unlimited polymorphic formal. */
5593 gfc_init_se (&parmse
, se
);
5594 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5596 else if (se
->ss
&& se
->ss
->info
->useflags
)
5602 /* An elemental function inside a scalarized loop. */
5603 gfc_init_se (&parmse
, se
);
5604 parm_kind
= ELEMENTAL
;
5606 /* When no fsym is present, ulim_copy is set and this is a third or
5607 fourth argument, use call-by-value instead of by reference to
5608 hand the length properties to the copy routine (i.e., most of the
5609 time this will be a call to a __copy_character_* routine where the
5610 third and fourth arguments are the lengths of a deferred length
5612 if ((fsym
&& fsym
->attr
.value
)
5613 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5614 gfc_conv_expr (&parmse
, e
);
5616 gfc_conv_expr_reference (&parmse
, e
);
5618 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5619 && e
->expr_type
== EXPR_FUNCTION
)
5620 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5623 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5624 && gfc_is_class_container_ref (e
))
5626 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5628 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5629 && e
->symtree
->n
.sym
->attr
.optional
)
5631 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5632 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5633 TREE_TYPE (parmse
.expr
),
5635 fold_convert (TREE_TYPE (parmse
.expr
),
5636 null_pointer_node
));
5640 /* If we are passing an absent array as optional dummy to an
5641 elemental procedure, make sure that we pass NULL when the data
5642 pointer is NULL. We need this extra conditional because of
5643 scalarization which passes arrays elements to the procedure,
5644 ignoring the fact that the array can be absent/unallocated/... */
5645 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5647 tree descriptor_data
;
5649 descriptor_data
= ss
->info
->data
.array
.data
;
5650 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5652 fold_convert (TREE_TYPE (descriptor_data
),
5653 null_pointer_node
));
5655 = fold_build3_loc (input_location
, COND_EXPR
,
5656 TREE_TYPE (parmse
.expr
),
5657 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5658 fold_convert (TREE_TYPE (parmse
.expr
),
5663 /* The scalarizer does not repackage the reference to a class
5664 array - instead it returns a pointer to the data element. */
5665 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5666 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5667 fsym
->attr
.intent
!= INTENT_IN
5668 && (CLASS_DATA (fsym
)->attr
.class_pointer
5669 || CLASS_DATA (fsym
)->attr
.allocatable
),
5671 && e
->expr_type
== EXPR_VARIABLE
5672 && e
->symtree
->n
.sym
->attr
.optional
,
5673 CLASS_DATA (fsym
)->attr
.class_pointer
5674 || CLASS_DATA (fsym
)->attr
.allocatable
);
5681 gfc_init_se (&parmse
, NULL
);
5683 /* Check whether the expression is a scalar or not; we cannot use
5684 e->rank as it can be nonzero for functions arguments. */
5685 argss
= gfc_walk_expr (e
);
5686 scalar
= argss
== gfc_ss_terminator
;
5688 gfc_free_ss_chain (argss
);
5690 /* Special handling for passing scalar polymorphic coarrays;
5691 otherwise one passes "class->_data.data" instead of "&class". */
5692 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5693 && fsym
&& fsym
->ts
.type
== BT_CLASS
5694 && CLASS_DATA (fsym
)->attr
.codimension
5695 && !CLASS_DATA (fsym
)->attr
.dimension
)
5697 gfc_add_class_array_ref (e
);
5698 parmse
.want_coarray
= 1;
5702 /* A scalar or transformational function. */
5705 if (e
->expr_type
== EXPR_VARIABLE
5706 && e
->symtree
->n
.sym
->attr
.cray_pointee
5707 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5709 /* The Cray pointer needs to be converted to a pointer to
5710 a type given by the expression. */
5711 gfc_conv_expr (&parmse
, e
);
5712 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5713 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5714 parmse
.expr
= convert (type
, tmp
);
5717 else if (sym
->attr
.is_bind_c
&& e
5718 && (is_CFI_desc (fsym
, NULL
)
5719 || non_unity_length_string
))
5720 /* Implement F2018, C.12.6.1: paragraph (2). */
5721 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5723 else if (fsym
&& fsym
->attr
.value
)
5725 if (fsym
->ts
.type
== BT_CHARACTER
5726 && fsym
->ts
.is_c_interop
5727 && fsym
->ns
->proc_name
!= NULL
5728 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5731 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5732 if (parmse
.expr
== NULL
)
5733 gfc_conv_expr (&parmse
, e
);
5737 gfc_conv_expr (&parmse
, e
);
5738 if (fsym
->attr
.optional
5739 && fsym
->ts
.type
!= BT_CLASS
5740 && fsym
->ts
.type
!= BT_DERIVED
)
5742 if (e
->expr_type
!= EXPR_VARIABLE
5743 || !e
->symtree
->n
.sym
->attr
.optional
5745 vec_safe_push (optionalargs
, boolean_true_node
);
5748 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5749 if (!e
->symtree
->n
.sym
->attr
.value
)
5751 = fold_build3_loc (input_location
, COND_EXPR
,
5752 TREE_TYPE (parmse
.expr
),
5754 fold_convert (TREE_TYPE (parmse
.expr
),
5755 integer_zero_node
));
5757 vec_safe_push (optionalargs
,
5758 fold_convert (boolean_type_node
,
5765 else if (arg
->name
&& arg
->name
[0] == '%')
5766 /* Argument list functions %VAL, %LOC and %REF are signalled
5767 through arg->name. */
5768 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5769 else if ((e
->expr_type
== EXPR_FUNCTION
)
5770 && ((e
->value
.function
.esym
5771 && e
->value
.function
.esym
->result
->attr
.pointer
)
5772 || (!e
->value
.function
.esym
5773 && e
->symtree
->n
.sym
->attr
.pointer
))
5774 && fsym
&& fsym
->attr
.target
)
5776 gfc_conv_expr (&parmse
, e
);
5777 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5780 else if (e
->expr_type
== EXPR_FUNCTION
5781 && e
->symtree
->n
.sym
->result
5782 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5783 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5785 /* Functions returning procedure pointers. */
5786 gfc_conv_expr (&parmse
, e
);
5787 if (fsym
&& fsym
->attr
.proc_pointer
)
5788 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5793 if (e
->ts
.type
== BT_CLASS
&& fsym
5794 && fsym
->ts
.type
== BT_CLASS
5795 && (!CLASS_DATA (fsym
)->as
5796 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5797 && CLASS_DATA (e
)->attr
.codimension
)
5799 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5800 gcc_assert (!CLASS_DATA (fsym
)->as
);
5801 gfc_add_class_array_ref (e
);
5802 parmse
.want_coarray
= 1;
5803 gfc_conv_expr_reference (&parmse
, e
);
5804 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5806 && e
->expr_type
== EXPR_VARIABLE
);
5808 else if (e
->ts
.type
== BT_CLASS
&& fsym
5809 && fsym
->ts
.type
== BT_CLASS
5810 && !CLASS_DATA (fsym
)->as
5811 && !CLASS_DATA (e
)->as
5812 && strcmp (fsym
->ts
.u
.derived
->name
,
5813 e
->ts
.u
.derived
->name
))
5815 type
= gfc_typenode_for_spec (&fsym
->ts
);
5816 var
= gfc_create_var (type
, fsym
->name
);
5817 gfc_conv_expr (&parmse
, e
);
5818 if (fsym
->attr
.optional
5819 && e
->expr_type
== EXPR_VARIABLE
5820 && e
->symtree
->n
.sym
->attr
.optional
)
5824 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5825 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5826 logical_type_node
, tmp
,
5827 fold_convert (TREE_TYPE (tmp
),
5828 null_pointer_node
));
5829 gfc_start_block (&block
);
5830 gfc_add_modify (&block
, var
,
5831 fold_build1_loc (input_location
,
5833 type
, parmse
.expr
));
5834 gfc_add_expr_to_block (&parmse
.pre
,
5835 fold_build3_loc (input_location
,
5836 COND_EXPR
, void_type_node
,
5837 cond
, gfc_finish_block (&block
),
5838 build_empty_stmt (input_location
)));
5839 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5840 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5841 TREE_TYPE (parmse
.expr
),
5843 fold_convert (TREE_TYPE (parmse
.expr
),
5844 null_pointer_node
));
5848 /* Since the internal representation of unlimited
5849 polymorphic expressions includes an extra field
5850 that other class objects do not, a cast to the
5851 formal type does not work. */
5852 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5856 /* Set the _data field. */
5857 tmp
= gfc_class_data_get (var
);
5858 efield
= fold_convert (TREE_TYPE (tmp
),
5859 gfc_class_data_get (parmse
.expr
));
5860 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5862 /* Set the _vptr field. */
5863 tmp
= gfc_class_vptr_get (var
);
5864 efield
= fold_convert (TREE_TYPE (tmp
),
5865 gfc_class_vptr_get (parmse
.expr
));
5866 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5868 /* Set the _len field. */
5869 tmp
= gfc_class_len_get (var
);
5870 gfc_add_modify (&parmse
.pre
, tmp
,
5871 build_int_cst (TREE_TYPE (tmp
), 0));
5875 tmp
= fold_build1_loc (input_location
,
5878 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5881 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5887 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5888 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5889 && !e
->symtree
->n
.sym
->attr
.dimension
5890 && !e
->symtree
->n
.sym
->attr
.pointer
5892 && !e
->symtree
->n
.sym
->attr
.dummy
5893 /* FIXME - PR 87395 and PR 41453 */
5894 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5895 && !e
->symtree
->n
.sym
->attr
.associate_var
5896 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5897 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5899 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5901 /* Catch base objects that are not variables. */
5902 if (e
->ts
.type
== BT_CLASS
5903 && e
->expr_type
!= EXPR_VARIABLE
5904 && expr
&& e
== expr
->base_expr
)
5905 base_object
= build_fold_indirect_ref_loc (input_location
,
5908 /* A class array element needs converting back to be a
5909 class object, if the formal argument is a class object. */
5910 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5911 && e
->ts
.type
== BT_CLASS
5912 && ((CLASS_DATA (fsym
)->as
5913 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5914 || CLASS_DATA (e
)->attr
.dimension
))
5915 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5916 fsym
->attr
.intent
!= INTENT_IN
5917 && (CLASS_DATA (fsym
)->attr
.class_pointer
5918 || CLASS_DATA (fsym
)->attr
.allocatable
),
5920 && e
->expr_type
== EXPR_VARIABLE
5921 && e
->symtree
->n
.sym
->attr
.optional
,
5922 CLASS_DATA (fsym
)->attr
.class_pointer
5923 || CLASS_DATA (fsym
)->attr
.allocatable
);
5925 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5926 allocated on entry, it must be deallocated. */
5927 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5928 && (fsym
->attr
.allocatable
5929 || (fsym
->ts
.type
== BT_CLASS
5930 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5935 gfc_init_block (&block
);
5937 if (e
->ts
.type
== BT_CLASS
)
5938 ptr
= gfc_class_data_get (ptr
);
5940 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5943 gfc_add_expr_to_block (&block
, tmp
);
5944 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5945 void_type_node
, ptr
,
5947 gfc_add_expr_to_block (&block
, tmp
);
5949 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5951 gfc_add_modify (&block
, ptr
,
5952 fold_convert (TREE_TYPE (ptr
),
5953 null_pointer_node
));
5954 gfc_add_expr_to_block (&block
, tmp
);
5956 else if (fsym
->ts
.type
== BT_CLASS
)
5959 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5960 tmp
= gfc_get_symbol_decl (vtab
);
5961 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5962 ptr
= gfc_class_vptr_get (parmse
.expr
);
5963 gfc_add_modify (&block
, ptr
,
5964 fold_convert (TREE_TYPE (ptr
), tmp
));
5965 gfc_add_expr_to_block (&block
, tmp
);
5968 if (fsym
->attr
.optional
5969 && e
->expr_type
== EXPR_VARIABLE
5970 && e
->symtree
->n
.sym
->attr
.optional
)
5972 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5974 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5975 gfc_finish_block (&block
),
5976 build_empty_stmt (input_location
));
5979 tmp
= gfc_finish_block (&block
);
5981 gfc_add_expr_to_block (&se
->pre
, tmp
);
5984 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5985 || fsym
->ts
.type
== BT_ASSUMED
)
5986 && e
->ts
.type
== BT_CLASS
5987 && !CLASS_DATA (e
)->attr
.dimension
5988 && !CLASS_DATA (e
)->attr
.codimension
)
5990 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5991 /* The result is a class temporary, whose _data component
5992 must be freed to avoid a memory leak. */
5993 if (e
->expr_type
== EXPR_FUNCTION
5994 && CLASS_DATA (e
)->attr
.allocatable
)
6000 /* Borrow the function symbol to make a call to
6001 gfc_add_finalizer_call and then restore it. */
6002 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6003 e
->symtree
->n
.sym
->backend_decl
6004 = TREE_OPERAND (parmse
.expr
, 0);
6005 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6006 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6007 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6009 gfc_free_expr (var
);
6010 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6011 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6013 /* Then free the class _data. */
6014 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6015 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6018 tmp
= build3_v (COND_EXPR
, tmp
,
6019 gfc_call_free (parmse
.expr
),
6020 build_empty_stmt (input_location
));
6021 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6022 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6026 /* Wrap scalar variable in a descriptor. We need to convert
6027 the address of a pointer back to the pointer itself before,
6028 we can assign it to the data field. */
6030 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6031 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6034 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6035 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6036 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6038 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6041 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6042 && ((fsym
->attr
.pointer
6043 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6044 || (fsym
->attr
.proc_pointer
6045 && !(e
->expr_type
== EXPR_VARIABLE
6046 && e
->symtree
->n
.sym
->attr
.dummy
))
6047 || (fsym
->attr
.proc_pointer
6048 && e
->expr_type
== EXPR_VARIABLE
6049 && gfc_is_proc_ptr_comp (e
))
6050 || (fsym
->attr
.allocatable
6051 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6053 /* Scalar pointer dummy args require an extra level of
6054 indirection. The null pointer already contains
6055 this level of indirection. */
6056 parm_kind
= SCALAR_POINTER
;
6057 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6061 else if (e
->ts
.type
== BT_CLASS
6062 && fsym
&& fsym
->ts
.type
== BT_CLASS
6063 && (CLASS_DATA (fsym
)->attr
.dimension
6064 || CLASS_DATA (fsym
)->attr
.codimension
))
6066 /* Pass a class array. */
6067 parmse
.use_offset
= 1;
6068 gfc_conv_expr_descriptor (&parmse
, e
);
6070 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6071 allocated on entry, it must be deallocated. */
6072 if (fsym
->attr
.intent
== INTENT_OUT
6073 && CLASS_DATA (fsym
)->attr
.allocatable
)
6078 gfc_init_block (&block
);
6080 ptr
= gfc_class_data_get (ptr
);
6082 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6083 NULL_TREE
, NULL_TREE
,
6085 GFC_CAF_COARRAY_NOCOARRAY
);
6086 gfc_add_expr_to_block (&block
, tmp
);
6087 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6088 void_type_node
, ptr
,
6090 gfc_add_expr_to_block (&block
, tmp
);
6091 gfc_reset_vptr (&block
, e
);
6093 if (fsym
->attr
.optional
6094 && e
->expr_type
== EXPR_VARIABLE
6096 || (e
->ref
->type
== REF_ARRAY
6097 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6098 && e
->symtree
->n
.sym
->attr
.optional
)
6100 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6102 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6103 gfc_finish_block (&block
),
6104 build_empty_stmt (input_location
));
6107 tmp
= gfc_finish_block (&block
);
6109 gfc_add_expr_to_block (&se
->pre
, tmp
);
6112 /* The conversion does not repackage the reference to a class
6113 array - _data descriptor. */
6114 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6115 fsym
->attr
.intent
!= INTENT_IN
6116 && (CLASS_DATA (fsym
)->attr
.class_pointer
6117 || CLASS_DATA (fsym
)->attr
.allocatable
),
6119 && e
->expr_type
== EXPR_VARIABLE
6120 && e
->symtree
->n
.sym
->attr
.optional
,
6121 CLASS_DATA (fsym
)->attr
.class_pointer
6122 || CLASS_DATA (fsym
)->attr
.allocatable
);
6126 /* If the argument is a function call that may not create
6127 a temporary for the result, we have to check that we
6128 can do it, i.e. that there is no alias between this
6129 argument and another one. */
6130 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6136 intent
= fsym
->attr
.intent
;
6138 intent
= INTENT_UNKNOWN
;
6140 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6142 parmse
.force_tmp
= 1;
6144 iarg
= e
->value
.function
.actual
->expr
;
6146 /* Temporary needed if aliasing due to host association. */
6147 if (sym
->attr
.contained
6149 && !sym
->attr
.implicit_pure
6150 && !sym
->attr
.use_assoc
6151 && iarg
->expr_type
== EXPR_VARIABLE
6152 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6153 parmse
.force_tmp
= 1;
6155 /* Ditto within module. */
6156 if (sym
->attr
.use_assoc
6158 && !sym
->attr
.implicit_pure
6159 && iarg
->expr_type
== EXPR_VARIABLE
6160 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6161 parmse
.force_tmp
= 1;
6164 if (sym
->attr
.is_bind_c
&& e
6165 && (is_CFI_desc (fsym
, NULL
) || non_unity_length_string
))
6166 /* Implement F2018, C.12.6.1: paragraph (2). */
6167 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6169 else if (e
->expr_type
== EXPR_VARIABLE
6170 && is_subref_array (e
)
6171 && !(fsym
&& fsym
->attr
.pointer
))
6172 /* The actual argument is a component reference to an
6173 array of derived types. In this case, the argument
6174 is converted to a temporary, which is passed and then
6175 written back after the procedure call. */
6176 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6177 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6178 fsym
&& fsym
->attr
.pointer
);
6180 else if (gfc_is_class_array_ref (e
, NULL
)
6181 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6182 /* The actual argument is a component reference to an
6183 array of derived types. In this case, the argument
6184 is converted to a temporary, which is passed and then
6185 written back after the procedure call.
6186 OOP-TODO: Insert code so that if the dynamic type is
6187 the same as the declared type, copy-in/copy-out does
6189 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6190 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6191 fsym
&& fsym
->attr
.pointer
);
6193 else if (gfc_is_class_array_function (e
)
6194 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6195 /* See previous comment. For function actual argument,
6196 the write out is not needed so the intent is set as
6199 e
->must_finalize
= 1;
6200 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6202 fsym
&& fsym
->attr
.pointer
);
6204 else if (fsym
&& fsym
->attr
.contiguous
6205 && !gfc_is_simply_contiguous (e
, false, true))
6207 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6208 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6209 fsym
&& fsym
->attr
.pointer
);
6212 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6215 /* Unallocated allocatable arrays and unassociated pointer arrays
6216 need their dtype setting if they are argument associated with
6217 assumed rank dummies. */
6218 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6219 && fsym
->as
->type
== AS_ASSUMED_RANK
)
6221 if (gfc_expr_attr (e
).pointer
6222 || gfc_expr_attr (e
).allocatable
)
6223 set_dtype_for_unallocated (&parmse
, e
);
6224 else if (e
->expr_type
== EXPR_VARIABLE
6225 && e
->symtree
->n
.sym
->attr
.dummy
6226 && e
->symtree
->n
.sym
->as
6227 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
6230 tmp
= build_fold_indirect_ref_loc (input_location
,
6232 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6233 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6234 gfc_rank_cst
[e
->rank
- 1],
6239 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6240 allocated on entry, it must be deallocated. */
6241 if (fsym
&& fsym
->attr
.allocatable
6242 && fsym
->attr
.intent
== INTENT_OUT
)
6244 if (fsym
->ts
.type
== BT_DERIVED
6245 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6247 // deallocate the components first
6248 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6249 parmse
.expr
, e
->rank
);
6250 if (tmp
!= NULL_TREE
)
6251 gfc_add_expr_to_block (&se
->pre
, tmp
);
6255 /* With bind(C), the actual argument is replaced by a bind-C
6256 descriptor; in this case, the data component arrives here,
6257 which shall not be dereferenced, but still freed and
6259 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6260 tmp
= build_fold_indirect_ref_loc (input_location
,
6262 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6263 tmp
= gfc_conv_descriptor_data_get (tmp
);
6264 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6265 NULL_TREE
, NULL_TREE
, true,
6267 GFC_CAF_COARRAY_NOCOARRAY
);
6268 if (fsym
->attr
.optional
6269 && e
->expr_type
== EXPR_VARIABLE
6270 && e
->symtree
->n
.sym
->attr
.optional
)
6271 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6273 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6274 tmp
, build_empty_stmt (input_location
));
6275 gfc_add_expr_to_block (&se
->pre
, tmp
);
6280 /* The case with fsym->attr.optional is that of a user subroutine
6281 with an interface indicating an optional argument. When we call
6282 an intrinsic subroutine, however, fsym is NULL, but we might still
6283 have an optional argument, so we proceed to the substitution
6285 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6287 /* If an optional argument is itself an optional dummy argument,
6288 check its presence and substitute a null if absent. This is
6289 only needed when passing an array to an elemental procedure
6290 as then array elements are accessed - or no NULL pointer is
6291 allowed and a "1" or "0" should be passed if not present.
6292 When passing a non-array-descriptor full array to a
6293 non-array-descriptor dummy, no check is needed. For
6294 array-descriptor actual to array-descriptor dummy, see
6295 PR 41911 for why a check has to be inserted.
6296 fsym == NULL is checked as intrinsics required the descriptor
6297 but do not always set fsym.
6298 Also, it is necessary to pass a NULL pointer to library routines
6299 which usually ignore optional arguments, so they can handle
6300 these themselves. */
6301 if (e
->expr_type
== EXPR_VARIABLE
6302 && e
->symtree
->n
.sym
->attr
.optional
6303 && (((e
->rank
!= 0 && elemental_proc
)
6304 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6308 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6309 || fsym
->as
->type
== AS_ASSUMED_RANK
6310 || fsym
->as
->type
== AS_DEFERRED
)))))
6311 || se
->ignore_optional
))
6312 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6313 e
->representation
.length
);
6318 /* Obtain the character length of an assumed character length
6319 length procedure from the typespec. */
6320 if (fsym
->ts
.type
== BT_CHARACTER
6321 && parmse
.string_length
== NULL_TREE
6322 && e
->ts
.type
== BT_PROCEDURE
6323 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6324 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6325 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6327 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6328 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6332 if (fsym
&& need_interface_mapping
&& e
)
6333 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6335 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6336 gfc_add_block_to_block (&post
, &parmse
.post
);
6338 /* Allocated allocatable components of derived types must be
6339 deallocated for non-variable scalars, array arguments to elemental
6340 procedures, and array arguments with descriptor to non-elemental
6341 procedures. As bounds information for descriptorless arrays is no
6342 longer available here, they are dealt with in trans-array.c
6343 (gfc_conv_array_parameter). */
6344 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
6345 && e
->ts
.u
.derived
->attr
.alloc_comp
6346 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
6347 && !expr_may_alias_variables (e
, elemental_proc
))
6350 /* It is known the e returns a structure type with at least one
6351 allocatable component. When e is a function, ensure that the
6352 function is called once only by using a temporary variable. */
6353 if (!DECL_P (parmse
.expr
))
6354 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
6355 parmse
.expr
, &se
->pre
);
6357 if (fsym
&& fsym
->attr
.value
)
6360 tmp
= build_fold_indirect_ref_loc (input_location
,
6363 parm_rank
= e
->rank
;
6371 case (SCALAR_POINTER
):
6372 tmp
= build_fold_indirect_ref_loc (input_location
,
6377 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
6379 /* The derived type is passed to gfc_deallocate_alloc_comp.
6380 Therefore, class actuals can be handled correctly but derived
6381 types passed to class formals need the _data component. */
6382 tmp
= gfc_class_data_get (tmp
);
6383 if (!CLASS_DATA (fsym
)->attr
.dimension
)
6384 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6387 if (e
->expr_type
== EXPR_OP
6388 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
6389 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
6392 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6393 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
6395 gfc_add_expr_to_block (&se
->post
, local_tmp
);
6398 if (!finalized
&& !e
->must_finalize
)
6400 if ((e
->ts
.type
== BT_CLASS
6401 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
6402 || e
->ts
.type
== BT_DERIVED
)
6403 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6405 else if (e
->ts
.type
== BT_CLASS
)
6406 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6408 gfc_prepend_expr_to_block (&post
, tmp
);
6412 /* Add argument checking of passing an unallocated/NULL actual to
6413 a nonallocatable/nonpointer dummy. */
6415 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6417 symbol_attribute attr
;
6421 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6422 attr
= gfc_expr_attr (e
);
6424 goto end_pointer_check
;
6426 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6427 allocatable to an optional dummy, cf. 12.5.2.12. */
6428 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6429 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6430 goto end_pointer_check
;
6434 /* If the actual argument is an optional pointer/allocatable and
6435 the formal argument takes an nonpointer optional value,
6436 it is invalid to pass a non-present argument on, even
6437 though there is no technical reason for this in gfortran.
6438 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6439 tree present
, null_ptr
, type
;
6441 if (attr
.allocatable
6442 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6443 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6444 "allocated or not present",
6445 e
->symtree
->n
.sym
->name
);
6446 else if (attr
.pointer
6447 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6448 msg
= xasprintf ("Pointer actual argument '%s' is not "
6449 "associated or not present",
6450 e
->symtree
->n
.sym
->name
);
6451 else if (attr
.proc_pointer
6452 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6453 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6454 "associated or not present",
6455 e
->symtree
->n
.sym
->name
);
6457 goto end_pointer_check
;
6459 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6460 type
= TREE_TYPE (present
);
6461 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6462 logical_type_node
, present
,
6464 null_pointer_node
));
6465 type
= TREE_TYPE (parmse
.expr
);
6466 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6467 logical_type_node
, parmse
.expr
,
6469 null_pointer_node
));
6470 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6471 logical_type_node
, present
, null_ptr
);
6475 if (attr
.allocatable
6476 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6477 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6478 "allocated", e
->symtree
->n
.sym
->name
);
6479 else if (attr
.pointer
6480 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6481 msg
= xasprintf ("Pointer actual argument '%s' is not "
6482 "associated", e
->symtree
->n
.sym
->name
);
6483 else if (attr
.proc_pointer
6484 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6485 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6486 "associated", e
->symtree
->n
.sym
->name
);
6488 goto end_pointer_check
;
6492 /* If the argument is passed by value, we need to strip the
6494 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6495 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6497 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6498 logical_type_node
, tmp
,
6499 fold_convert (TREE_TYPE (tmp
),
6500 null_pointer_node
));
6503 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6509 /* Deferred length dummies pass the character length by reference
6510 so that the value can be returned. */
6511 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6513 if (INDIRECT_REF_P (parmse
.string_length
))
6514 /* In chains of functions/procedure calls the string_length already
6515 is a pointer to the variable holding the length. Therefore
6516 remove the deref on call. */
6517 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6520 tmp
= parmse
.string_length
;
6521 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6522 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6523 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6527 /* Character strings are passed as two parameters, a length and a
6528 pointer - except for Bind(c) which only passes the pointer.
6529 An unlimited polymorphic formal argument likewise does not
6531 if (parmse
.string_length
!= NULL_TREE
6532 && !sym
->attr
.is_bind_c
6533 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6534 vec_safe_push (stringargs
, parmse
.string_length
);
6536 /* When calling __copy for character expressions to unlimited
6537 polymorphic entities, the dst argument needs a string length. */
6538 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6539 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6540 && arg
->next
&& arg
->next
->expr
6541 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6542 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6543 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6544 vec_safe_push (stringargs
, parmse
.string_length
);
6546 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6547 pass the token and the offset as additional arguments. */
6548 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6549 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6550 && !fsym
->attr
.allocatable
)
6551 || (fsym
->ts
.type
== BT_CLASS
6552 && CLASS_DATA (fsym
)->attr
.codimension
6553 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6555 /* Token and offset. */
6556 vec_safe_push (stringargs
, null_pointer_node
);
6557 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6558 gcc_assert (fsym
->attr
.optional
);
6560 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6561 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6562 && !fsym
->attr
.allocatable
)
6563 || (fsym
->ts
.type
== BT_CLASS
6564 && CLASS_DATA (fsym
)->attr
.codimension
6565 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6567 tree caf_decl
, caf_type
;
6570 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6571 caf_type
= TREE_TYPE (caf_decl
);
6573 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6574 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6575 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6576 tmp
= gfc_conv_descriptor_token (caf_decl
);
6577 else if (DECL_LANG_SPECIFIC (caf_decl
)
6578 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6579 tmp
= GFC_DECL_TOKEN (caf_decl
);
6582 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6583 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6584 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6587 vec_safe_push (stringargs
, tmp
);
6589 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6590 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6591 offset
= build_int_cst (gfc_array_index_type
, 0);
6592 else if (DECL_LANG_SPECIFIC (caf_decl
)
6593 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6594 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6595 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6596 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6598 offset
= build_int_cst (gfc_array_index_type
, 0);
6600 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6601 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6604 gcc_assert (POINTER_TYPE_P (caf_type
));
6608 tmp2
= fsym
->ts
.type
== BT_CLASS
6609 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6610 if ((fsym
->ts
.type
!= BT_CLASS
6611 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6612 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6613 || (fsym
->ts
.type
== BT_CLASS
6614 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6615 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6617 if (fsym
->ts
.type
== BT_CLASS
)
6618 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6621 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6622 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6624 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6625 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6627 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6628 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6631 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6634 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6635 gfc_array_index_type
,
6636 fold_convert (gfc_array_index_type
, tmp2
),
6637 fold_convert (gfc_array_index_type
, tmp
));
6638 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6639 gfc_array_index_type
, offset
, tmp
);
6641 vec_safe_push (stringargs
, offset
);
6644 vec_safe_push (arglist
, parmse
.expr
);
6646 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6650 else if (sym
->ts
.type
== BT_CLASS
)
6651 ts
= CLASS_DATA (sym
)->ts
;
6655 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6656 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6657 else if (ts
.type
== BT_CHARACTER
)
6659 if (ts
.u
.cl
->length
== NULL
)
6661 /* Assumed character length results are not allowed by C418 of the 2003
6662 standard and are trapped in resolve.c; except in the case of SPREAD
6663 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6664 we take the character length of the first argument for the result.
6665 For dummies, we have to look through the formal argument list for
6666 this function and use the character length found there.*/
6668 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6669 else if (!sym
->attr
.dummy
)
6670 cl
.backend_decl
= (*stringargs
)[0];
6673 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6674 for (; formal
; formal
= formal
->next
)
6675 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6676 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6678 len
= cl
.backend_decl
;
6684 /* Calculate the length of the returned string. */
6685 gfc_init_se (&parmse
, NULL
);
6686 if (need_interface_mapping
)
6687 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6689 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6690 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6691 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6693 /* TODO: It would be better to have the charlens as
6694 gfc_charlen_type_node already when the interface is
6695 created instead of converting it here (see PR 84615). */
6696 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6697 gfc_charlen_type_node
,
6698 fold_convert (gfc_charlen_type_node
, tmp
),
6699 build_zero_cst (gfc_charlen_type_node
));
6700 cl
.backend_decl
= tmp
;
6703 /* Set up a charlen structure for it. */
6708 len
= cl
.backend_decl
;
6711 byref
= (comp
&& (comp
->attr
.dimension
6712 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6713 || (!comp
&& gfc_return_by_reference (sym
));
6716 if (se
->direct_byref
)
6718 /* Sometimes, too much indirection can be applied; e.g. for
6719 function_result = array_valued_recursive_function. */
6720 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6721 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6722 && GFC_DESCRIPTOR_TYPE_P
6723 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6724 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6727 /* If the lhs of an assignment x = f(..) is allocatable and
6728 f2003 is allowed, we must do the automatic reallocation.
6729 TODO - deal with intrinsics, without using a temporary. */
6730 if (flag_realloc_lhs
6731 && se
->ss
&& se
->ss
->loop_chain
6732 && se
->ss
->loop_chain
->is_alloc_lhs
6733 && !expr
->value
.function
.isym
6734 && sym
->result
->as
!= NULL
)
6736 /* Evaluate the bounds of the result, if known. */
6737 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6740 /* Perform the automatic reallocation. */
6741 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6743 gfc_add_expr_to_block (&se
->pre
, tmp
);
6745 /* Pass the temporary as the first argument. */
6746 result
= info
->descriptor
;
6749 result
= build_fold_indirect_ref_loc (input_location
,
6751 vec_safe_push (retargs
, se
->expr
);
6753 else if (comp
&& comp
->attr
.dimension
)
6755 gcc_assert (se
->loop
&& info
);
6757 /* Set the type of the array. */
6758 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6759 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6761 /* Evaluate the bounds of the result, if known. */
6762 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6764 /* If the lhs of an assignment x = f(..) is allocatable and
6765 f2003 is allowed, we must not generate the function call
6766 here but should just send back the results of the mapping.
6767 This is signalled by the function ss being flagged. */
6768 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6770 gfc_free_interface_mapping (&mapping
);
6771 return has_alternate_specifier
;
6774 /* Create a temporary to store the result. In case the function
6775 returns a pointer, the temporary will be a shallow copy and
6776 mustn't be deallocated. */
6777 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6778 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6779 tmp
, NULL_TREE
, false,
6780 !comp
->attr
.pointer
, callee_alloc
,
6781 &se
->ss
->info
->expr
->where
);
6783 /* Pass the temporary as the first argument. */
6784 result
= info
->descriptor
;
6785 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6786 vec_safe_push (retargs
, tmp
);
6788 else if (!comp
&& sym
->result
->attr
.dimension
)
6790 gcc_assert (se
->loop
&& info
);
6792 /* Set the type of the array. */
6793 tmp
= gfc_typenode_for_spec (&ts
);
6794 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6796 /* Evaluate the bounds of the result, if known. */
6797 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6799 /* If the lhs of an assignment x = f(..) is allocatable and
6800 f2003 is allowed, we must not generate the function call
6801 here but should just send back the results of the mapping.
6802 This is signalled by the function ss being flagged. */
6803 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6805 gfc_free_interface_mapping (&mapping
);
6806 return has_alternate_specifier
;
6809 /* Create a temporary to store the result. In case the function
6810 returns a pointer, the temporary will be a shallow copy and
6811 mustn't be deallocated. */
6812 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6813 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6814 tmp
, NULL_TREE
, false,
6815 !sym
->attr
.pointer
, callee_alloc
,
6816 &se
->ss
->info
->expr
->where
);
6818 /* Pass the temporary as the first argument. */
6819 result
= info
->descriptor
;
6820 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6821 vec_safe_push (retargs
, tmp
);
6823 else if (ts
.type
== BT_CHARACTER
)
6825 /* Pass the string length. */
6826 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6827 type
= build_pointer_type (type
);
6829 /* Emit a DECL_EXPR for the VLA type. */
6830 tmp
= TREE_TYPE (type
);
6832 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6834 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6835 DECL_ARTIFICIAL (tmp
) = 1;
6836 DECL_IGNORED_P (tmp
) = 1;
6837 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6838 TREE_TYPE (tmp
), tmp
);
6839 gfc_add_expr_to_block (&se
->pre
, tmp
);
6842 /* Return an address to a char[0:len-1]* temporary for
6843 character pointers. */
6844 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6845 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6847 var
= gfc_create_var (type
, "pstr");
6849 if ((!comp
&& sym
->attr
.allocatable
)
6850 || (comp
&& comp
->attr
.allocatable
))
6852 gfc_add_modify (&se
->pre
, var
,
6853 fold_convert (TREE_TYPE (var
),
6854 null_pointer_node
));
6855 tmp
= gfc_call_free (var
);
6856 gfc_add_expr_to_block (&se
->post
, tmp
);
6859 /* Provide an address expression for the function arguments. */
6860 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6863 var
= gfc_conv_string_tmp (se
, type
, len
);
6865 vec_safe_push (retargs
, var
);
6869 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6871 type
= gfc_get_complex_type (ts
.kind
);
6872 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6873 vec_safe_push (retargs
, var
);
6876 /* Add the string length to the argument list. */
6877 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6881 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6882 TREE_STATIC (tmp
) = 1;
6883 gfc_add_modify (&se
->pre
, tmp
,
6884 build_int_cst (TREE_TYPE (tmp
), 0));
6885 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6886 vec_safe_push (retargs
, tmp
);
6888 else if (ts
.type
== BT_CHARACTER
)
6889 vec_safe_push (retargs
, len
);
6891 gfc_free_interface_mapping (&mapping
);
6893 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6894 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6895 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6896 vec_safe_reserve (retargs
, arglen
);
6898 /* Add the return arguments. */
6899 vec_safe_splice (retargs
, arglist
);
6901 /* Add the hidden present status for optional+value to the arguments. */
6902 vec_safe_splice (retargs
, optionalargs
);
6904 /* Add the hidden string length parameters to the arguments. */
6905 vec_safe_splice (retargs
, stringargs
);
6907 /* We may want to append extra arguments here. This is used e.g. for
6908 calls to libgfortran_matmul_??, which need extra information. */
6909 vec_safe_splice (retargs
, append_args
);
6913 /* Generate the actual call. */
6914 if (base_object
== NULL_TREE
)
6915 conv_function_val (se
, sym
, expr
, args
);
6917 conv_base_obj_fcn_val (se
, base_object
, expr
);
6919 /* If there are alternate return labels, function type should be
6920 integer. Can't modify the type in place though, since it can be shared
6921 with other functions. For dummy arguments, the typing is done to
6922 this result, even if it has to be repeated for each call. */
6923 if (has_alternate_specifier
6924 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6926 if (!sym
->attr
.dummy
)
6928 TREE_TYPE (sym
->backend_decl
)
6929 = build_function_type (integer_type_node
,
6930 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6931 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6934 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6937 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6938 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6940 /* Allocatable scalar function results must be freed and nullified
6941 after use. This necessitates the creation of a temporary to
6942 hold the result to prevent duplicate calls. */
6943 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6944 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6945 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6947 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6948 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6950 tmp
= gfc_call_free (tmp
);
6951 gfc_add_expr_to_block (&post
, tmp
);
6952 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6955 /* If we have a pointer function, but we don't want a pointer, e.g.
6958 where f is pointer valued, we have to dereference the result. */
6959 if (!se
->want_pointer
&& !byref
6960 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6961 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6962 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6964 /* f2c calling conventions require a scalar default real function to
6965 return a double precision result. Convert this back to default
6966 real. We only care about the cases that can happen in Fortran 77.
6968 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6969 && sym
->ts
.kind
== gfc_default_real_kind
6970 && !sym
->attr
.always_explicit
)
6971 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6973 /* A pure function may still have side-effects - it may modify its
6975 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6977 if (!sym
->attr
.pure
)
6978 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6983 /* Add the function call to the pre chain. There is no expression. */
6984 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6985 se
->expr
= NULL_TREE
;
6987 if (!se
->direct_byref
)
6989 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6991 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6993 /* Check the data pointer hasn't been modified. This would
6994 happen in a function returning a pointer. */
6995 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6996 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6999 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7002 se
->expr
= info
->descriptor
;
7003 /* Bundle in the string length. */
7004 se
->string_length
= len
;
7006 else if (ts
.type
== BT_CHARACTER
)
7008 /* Dereference for character pointer results. */
7009 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7010 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7011 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7015 se
->string_length
= len
;
7019 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7020 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7025 /* Associate the rhs class object's meta-data with the result, when the
7026 result is a temporary. */
7027 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7028 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7029 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7032 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7034 gfc_init_se (&parmse
, NULL
);
7035 parmse
.data_not_needed
= 1;
7036 gfc_conv_expr (&parmse
, class_expr
);
7037 if (!DECL_LANG_SPECIFIC (result
))
7038 gfc_allocate_lang_decl (result
);
7039 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7040 gfc_free_expr (class_expr
);
7041 /* -fcheck= can add diagnostic code, which has to be placed before
7043 if (parmse
.pre
.head
!= NULL
)
7044 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7045 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7048 /* Follow the function call with the argument post block. */
7051 gfc_add_block_to_block (&se
->pre
, &post
);
7053 /* Transformational functions of derived types with allocatable
7054 components must have the result allocatable components copied when the
7055 argument is actually given. */
7056 arg
= expr
->value
.function
.actual
;
7057 if (result
&& arg
&& expr
->rank
7058 && expr
->value
.function
.isym
7059 && expr
->value
.function
.isym
->transformational
7061 && arg
->expr
->ts
.type
== BT_DERIVED
7062 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7065 /* Copy the allocatable components. We have to use a
7066 temporary here to prevent source allocatable components
7067 from being corrupted. */
7068 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7069 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7070 result
, tmp2
, expr
->rank
, 0);
7071 gfc_add_expr_to_block (&se
->pre
, tmp
);
7072 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7074 gfc_add_expr_to_block (&se
->pre
, tmp
);
7076 /* Finally free the temporary's data field. */
7077 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7078 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7079 NULL_TREE
, NULL_TREE
, true,
7080 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7081 gfc_add_expr_to_block (&se
->pre
, tmp
);
7086 /* For a function with a class array result, save the result as
7087 a temporary, set the info fields needed by the scalarizer and
7088 call the finalization function of the temporary. Note that the
7089 nullification of allocatable components needed by the result
7090 is done in gfc_trans_assignment_1. */
7091 if (expr
&& ((gfc_is_class_array_function (expr
)
7092 && se
->ss
&& se
->ss
->loop
)
7093 || gfc_is_alloc_class_scalar_function (expr
))
7094 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7095 && expr
->must_finalize
)
7100 if (se
->ss
&& se
->ss
->loop
)
7102 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7103 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7104 tmp
= gfc_class_data_get (se
->expr
);
7105 info
->descriptor
= tmp
;
7106 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7107 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7108 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7110 tree dim
= gfc_rank_cst
[n
];
7111 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7112 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7117 /* TODO Eliminate the doubling of temporaries. This
7118 one is necessary to ensure no memory leakage. */
7119 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7120 tmp
= gfc_class_data_get (se
->expr
);
7121 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7122 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7125 if ((gfc_is_class_array_function (expr
)
7126 || gfc_is_alloc_class_scalar_function (expr
))
7127 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7128 goto no_finalization
;
7130 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7131 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7134 fold_convert (TREE_TYPE (final_fndecl
),
7135 null_pointer_node
));
7136 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7138 tmp
= build_call_expr_loc (input_location
,
7140 gfc_build_addr_expr (NULL
, tmp
),
7141 gfc_class_vtab_size_get (se
->expr
),
7142 boolean_false_node
);
7143 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7144 void_type_node
, is_final
, tmp
,
7145 build_empty_stmt (input_location
));
7147 if (se
->ss
&& se
->ss
->loop
)
7149 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7150 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7153 fold_convert (TREE_TYPE (info
->data
),
7154 null_pointer_node
));
7155 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7156 void_type_node
, tmp
,
7157 gfc_call_free (info
->data
),
7158 build_empty_stmt (input_location
));
7159 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7164 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7165 classdata
= gfc_class_data_get (se
->expr
);
7166 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7169 fold_convert (TREE_TYPE (classdata
),
7170 null_pointer_node
));
7171 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7172 void_type_node
, tmp
,
7173 gfc_call_free (classdata
),
7174 build_empty_stmt (input_location
));
7175 gfc_add_expr_to_block (&se
->post
, tmp
);
7180 gfc_add_block_to_block (&se
->post
, &post
);
7183 return has_alternate_specifier
;
7187 /* Fill a character string with spaces. */
7190 fill_with_spaces (tree start
, tree type
, tree size
)
7192 stmtblock_t block
, loop
;
7193 tree i
, el
, exit_label
, cond
, tmp
;
7195 /* For a simple char type, we can call memset(). */
7196 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7197 return build_call_expr_loc (input_location
,
7198 builtin_decl_explicit (BUILT_IN_MEMSET
),
7200 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7201 lang_hooks
.to_target_charset (' ')),
7202 fold_convert (size_type_node
, size
));
7204 /* Otherwise, we use a loop:
7205 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7209 /* Initialize variables. */
7210 gfc_init_block (&block
);
7211 i
= gfc_create_var (sizetype
, "i");
7212 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7213 el
= gfc_create_var (build_pointer_type (type
), "el");
7214 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7215 exit_label
= gfc_build_label_decl (NULL_TREE
);
7216 TREE_USED (exit_label
) = 1;
7220 gfc_init_block (&loop
);
7222 /* Exit condition. */
7223 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7224 build_zero_cst (sizetype
));
7225 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7226 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7227 build_empty_stmt (input_location
));
7228 gfc_add_expr_to_block (&loop
, tmp
);
7231 gfc_add_modify (&loop
,
7232 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7233 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7235 /* Increment loop variables. */
7236 gfc_add_modify (&loop
, i
,
7237 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7238 TYPE_SIZE_UNIT (type
)));
7239 gfc_add_modify (&loop
, el
,
7240 fold_build_pointer_plus_loc (input_location
,
7241 el
, TYPE_SIZE_UNIT (type
)));
7243 /* Making the loop... actually loop! */
7244 tmp
= gfc_finish_block (&loop
);
7245 tmp
= build1_v (LOOP_EXPR
, tmp
);
7246 gfc_add_expr_to_block (&block
, tmp
);
7248 /* The exit label. */
7249 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7250 gfc_add_expr_to_block (&block
, tmp
);
7253 return gfc_finish_block (&block
);
7257 /* Generate code to copy a string. */
7260 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7261 int dkind
, tree slength
, tree src
, int skind
)
7263 tree tmp
, dlen
, slen
;
7272 stmtblock_t tempblock
;
7274 gcc_assert (dkind
== skind
);
7276 if (slength
!= NULL_TREE
)
7278 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7279 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
7283 slen
= build_one_cst (gfc_charlen_type_node
);
7287 if (dlength
!= NULL_TREE
)
7289 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
7290 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
7294 dlen
= build_one_cst (gfc_charlen_type_node
);
7298 /* Assign directly if the types are compatible. */
7299 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
7300 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
7302 gfc_add_modify (block
, dsc
, ssc
);
7306 /* The string copy algorithm below generates code like
7310 if (srclen < destlen)
7312 memmove (dest, src, srclen);
7314 memset (&dest[srclen], ' ', destlen - srclen);
7318 // Truncate if too long.
7319 memmove (dest, src, destlen);
7324 /* Do nothing if the destination length is zero. */
7325 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
7326 build_zero_cst (TREE_TYPE (dlen
)));
7328 /* For non-default character kinds, we have to multiply the string
7329 length by the base type size. */
7330 chartype
= gfc_get_char_type (dkind
);
7331 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
7333 fold_convert (TREE_TYPE (slen
),
7334 TYPE_SIZE_UNIT (chartype
)));
7335 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
7337 fold_convert (TREE_TYPE (dlen
),
7338 TYPE_SIZE_UNIT (chartype
)));
7340 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
7341 dest
= fold_convert (pvoid_type_node
, dest
);
7343 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
7345 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
7346 src
= fold_convert (pvoid_type_node
, src
);
7348 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7350 /* Truncate string if source is too long. */
7351 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
7354 /* Copy and pad with spaces. */
7355 tmp3
= build_call_expr_loc (input_location
,
7356 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7358 fold_convert (size_type_node
, slen
));
7360 /* Wstringop-overflow appears at -O3 even though this warning is not
7361 explicitly available in fortran nor can it be switched off. If the
7362 source length is a constant, its negative appears as a very large
7363 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7364 the result of the MINUS_EXPR suppresses this spurious warning. */
7365 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7366 TREE_TYPE(dlen
), dlen
, slen
);
7367 if (slength
&& TREE_CONSTANT (slength
))
7368 tmp
= gfc_evaluate_now (tmp
, block
);
7370 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
7371 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
7373 gfc_init_block (&tempblock
);
7374 gfc_add_expr_to_block (&tempblock
, tmp3
);
7375 gfc_add_expr_to_block (&tempblock
, tmp4
);
7376 tmp3
= gfc_finish_block (&tempblock
);
7378 /* The truncated memmove if the slen >= dlen. */
7379 tmp2
= build_call_expr_loc (input_location
,
7380 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7382 fold_convert (size_type_node
, dlen
));
7384 /* The whole copy_string function is there. */
7385 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
7387 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7388 build_empty_stmt (input_location
));
7389 gfc_add_expr_to_block (block
, tmp
);
7393 /* Translate a statement function.
7394 The value of a statement function reference is obtained by evaluating the
7395 expression using the values of the actual arguments for the values of the
7396 corresponding dummy arguments. */
7399 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
7403 gfc_formal_arglist
*fargs
;
7404 gfc_actual_arglist
*args
;
7407 gfc_saved_var
*saved_vars
;
7413 sym
= expr
->symtree
->n
.sym
;
7414 args
= expr
->value
.function
.actual
;
7415 gfc_init_se (&lse
, NULL
);
7416 gfc_init_se (&rse
, NULL
);
7419 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7421 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7422 temp_vars
= XCNEWVEC (tree
, n
);
7424 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7425 fargs
= fargs
->next
, n
++)
7427 /* Each dummy shall be specified, explicitly or implicitly, to be
7429 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7432 if (fsym
->ts
.type
== BT_CHARACTER
)
7434 /* Copy string arguments. */
7437 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7438 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7440 /* Create a temporary to hold the value. */
7441 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7442 fsym
->ts
.u
.cl
->backend_decl
7443 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7445 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7446 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7448 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7450 gfc_conv_expr (&rse
, args
->expr
);
7451 gfc_conv_string_parameter (&rse
);
7452 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7453 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7455 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7456 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7457 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7458 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7462 /* For everything else, just evaluate the expression. */
7464 /* Create a temporary to hold the value. */
7465 type
= gfc_typenode_for_spec (&fsym
->ts
);
7466 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7468 gfc_conv_expr (&lse
, args
->expr
);
7470 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7471 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7472 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7478 /* Use the temporary variables in place of the real ones. */
7479 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7480 fargs
= fargs
->next
, n
++)
7481 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7483 gfc_conv_expr (se
, sym
->value
);
7485 if (sym
->ts
.type
== BT_CHARACTER
)
7487 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7489 /* Force the expression to the correct length. */
7490 if (!INTEGER_CST_P (se
->string_length
)
7491 || tree_int_cst_lt (se
->string_length
,
7492 sym
->ts
.u
.cl
->backend_decl
))
7494 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7495 tmp
= gfc_create_var (type
, sym
->name
);
7496 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7497 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7498 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7502 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7505 /* Restore the original variables. */
7506 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7507 fargs
= fargs
->next
, n
++)
7508 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7514 /* Translate a function expression. */
7517 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7521 if (expr
->value
.function
.isym
)
7523 gfc_conv_intrinsic_function (se
, expr
);
7527 /* expr.value.function.esym is the resolved (specific) function symbol for
7528 most functions. However this isn't set for dummy procedures. */
7529 sym
= expr
->value
.function
.esym
;
7531 sym
= expr
->symtree
->n
.sym
;
7533 /* The IEEE_ARITHMETIC functions are caught here. */
7534 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7535 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7538 /* We distinguish statement functions from general functions to improve
7539 runtime performance. */
7540 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7542 gfc_conv_statement_function (se
, expr
);
7546 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7551 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7554 is_zero_initializer_p (gfc_expr
* expr
)
7556 if (expr
->expr_type
!= EXPR_CONSTANT
)
7559 /* We ignore constants with prescribed memory representations for now. */
7560 if (expr
->representation
.string
)
7563 switch (expr
->ts
.type
)
7566 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7569 return mpfr_zero_p (expr
->value
.real
)
7570 && MPFR_SIGN (expr
->value
.real
) >= 0;
7573 return expr
->value
.logical
== 0;
7576 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7577 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7578 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7579 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7589 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7594 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7595 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7597 gfc_conv_tmp_array_ref (se
);
7601 /* Build a static initializer. EXPR is the expression for the initial value.
7602 The other parameters describe the variable of the component being
7603 initialized. EXPR may be null. */
7606 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7607 bool array
, bool pointer
, bool procptr
)
7611 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7612 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7613 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7614 return build_constructor (type
, NULL
);
7616 if (!(expr
|| pointer
|| procptr
))
7619 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7620 (these are the only two iso_c_binding derived types that can be
7621 used as initialization expressions). If so, we need to modify
7622 the 'expr' to be that for a (void *). */
7623 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7624 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7626 if (TREE_CODE (type
) == ARRAY_TYPE
)
7627 return build_constructor (type
, NULL
);
7628 else if (POINTER_TYPE_P (type
))
7629 return build_int_cst (type
, 0);
7634 if (array
&& !procptr
)
7637 /* Arrays need special handling. */
7639 ctor
= gfc_build_null_descriptor (type
);
7640 /* Special case assigning an array to zero. */
7641 else if (is_zero_initializer_p (expr
))
7642 ctor
= build_constructor (type
, NULL
);
7644 ctor
= gfc_conv_array_initializer (type
, expr
);
7645 TREE_STATIC (ctor
) = 1;
7648 else if (pointer
|| procptr
)
7650 if (ts
->type
== BT_CLASS
&& !procptr
)
7652 gfc_init_se (&se
, NULL
);
7653 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7654 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7655 TREE_STATIC (se
.expr
) = 1;
7658 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7659 return fold_convert (type
, null_pointer_node
);
7662 gfc_init_se (&se
, NULL
);
7663 se
.want_pointer
= 1;
7664 gfc_conv_expr (&se
, expr
);
7665 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7675 gfc_init_se (&se
, NULL
);
7676 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7677 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7679 gfc_conv_structure (&se
, expr
, 1);
7680 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7681 TREE_STATIC (se
.expr
) = 1;
7686 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
7687 TREE_STATIC (ctor
) = 1;
7692 gfc_init_se (&se
, NULL
);
7693 gfc_conv_constant (&se
, expr
);
7694 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7701 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7707 gfc_array_info
*lss_array
;
7714 gfc_start_block (&block
);
7716 /* Initialize the scalarizer. */
7717 gfc_init_loopinfo (&loop
);
7719 gfc_init_se (&lse
, NULL
);
7720 gfc_init_se (&rse
, NULL
);
7723 rss
= gfc_walk_expr (expr
);
7724 if (rss
== gfc_ss_terminator
)
7725 /* The rhs is scalar. Add a ss for the expression. */
7726 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7728 /* Create a SS for the destination. */
7729 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7731 lss_array
= &lss
->info
->data
.array
;
7732 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7733 lss_array
->descriptor
= dest
;
7734 lss_array
->data
= gfc_conv_array_data (dest
);
7735 lss_array
->offset
= gfc_conv_array_offset (dest
);
7736 for (n
= 0; n
< cm
->as
->rank
; n
++)
7738 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7739 lss_array
->stride
[n
] = gfc_index_one_node
;
7741 mpz_init (lss_array
->shape
[n
]);
7742 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7743 cm
->as
->lower
[n
]->value
.integer
);
7744 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7747 /* Associate the SS with the loop. */
7748 gfc_add_ss_to_loop (&loop
, lss
);
7749 gfc_add_ss_to_loop (&loop
, rss
);
7751 /* Calculate the bounds of the scalarization. */
7752 gfc_conv_ss_startstride (&loop
);
7754 /* Setup the scalarizing loops. */
7755 gfc_conv_loop_setup (&loop
, &expr
->where
);
7757 /* Setup the gfc_se structures. */
7758 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7759 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7762 gfc_mark_ss_chain_used (rss
, 1);
7764 gfc_mark_ss_chain_used (lss
, 1);
7766 /* Start the scalarized loop body. */
7767 gfc_start_scalarized_body (&loop
, &body
);
7769 gfc_conv_tmp_array_ref (&lse
);
7770 if (cm
->ts
.type
== BT_CHARACTER
)
7771 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7773 gfc_conv_expr (&rse
, expr
);
7775 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7776 gfc_add_expr_to_block (&body
, tmp
);
7778 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7780 /* Generate the copying loops. */
7781 gfc_trans_scalarizing_loops (&loop
, &body
);
7783 /* Wrap the whole thing up. */
7784 gfc_add_block_to_block (&block
, &loop
.pre
);
7785 gfc_add_block_to_block (&block
, &loop
.post
);
7787 gcc_assert (lss_array
->shape
!= NULL
);
7788 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7789 gfc_cleanup_loop (&loop
);
7791 return gfc_finish_block (&block
);
7796 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7806 gfc_expr
*arg
= NULL
;
7808 gfc_start_block (&block
);
7809 gfc_init_se (&se
, NULL
);
7811 /* Get the descriptor for the expressions. */
7812 se
.want_pointer
= 0;
7813 gfc_conv_expr_descriptor (&se
, expr
);
7814 gfc_add_block_to_block (&block
, &se
.pre
);
7815 gfc_add_modify (&block
, dest
, se
.expr
);
7817 /* Deal with arrays of derived types with allocatable components. */
7818 if (gfc_bt_struct (cm
->ts
.type
)
7819 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7820 // TODO: Fix caf_mode
7821 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7824 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7825 && CLASS_DATA(cm
)->attr
.allocatable
)
7827 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7828 // TODO: Fix caf_mode
7829 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7834 tmp
= TREE_TYPE (dest
);
7835 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7836 tmp
, expr
->rank
, NULL_TREE
);
7840 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7841 TREE_TYPE(cm
->backend_decl
),
7842 cm
->as
->rank
, NULL_TREE
);
7844 gfc_add_expr_to_block (&block
, tmp
);
7845 gfc_add_block_to_block (&block
, &se
.post
);
7847 if (expr
->expr_type
!= EXPR_VARIABLE
)
7848 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7851 /* We need to know if the argument of a conversion function is a
7852 variable, so that the correct lower bound can be used. */
7853 if (expr
->expr_type
== EXPR_FUNCTION
7854 && expr
->value
.function
.isym
7855 && expr
->value
.function
.isym
->conversion
7856 && expr
->value
.function
.actual
->expr
7857 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7858 arg
= expr
->value
.function
.actual
->expr
;
7860 /* Obtain the array spec of full array references. */
7862 as
= gfc_get_full_arrayspec_from_expr (arg
);
7864 as
= gfc_get_full_arrayspec_from_expr (expr
);
7866 /* Shift the lbound and ubound of temporaries to being unity,
7867 rather than zero, based. Always calculate the offset. */
7868 offset
= gfc_conv_descriptor_offset_get (dest
);
7869 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7870 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7872 for (n
= 0; n
< expr
->rank
; n
++)
7877 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7878 TODO It looks as if gfc_conv_expr_descriptor should return
7879 the correct bounds and that the following should not be
7880 necessary. This would simplify gfc_conv_intrinsic_bound
7882 if (as
&& as
->lower
[n
])
7885 gfc_init_se (&lbse
, NULL
);
7886 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7887 gfc_add_block_to_block (&block
, &lbse
.pre
);
7888 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7892 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7893 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7897 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7900 lbound
= gfc_index_one_node
;
7902 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7904 /* Shift the bounds and set the offset accordingly. */
7905 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7906 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7907 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7908 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7910 gfc_conv_descriptor_ubound_set (&block
, dest
,
7911 gfc_rank_cst
[n
], tmp
);
7912 gfc_conv_descriptor_lbound_set (&block
, dest
,
7913 gfc_rank_cst
[n
], lbound
);
7915 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7916 gfc_conv_descriptor_lbound_get (dest
,
7918 gfc_conv_descriptor_stride_get (dest
,
7920 gfc_add_modify (&block
, tmp2
, tmp
);
7921 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7923 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7928 /* If a conversion expression has a null data pointer
7929 argument, nullify the allocatable component. */
7933 if (arg
->symtree
->n
.sym
->attr
.allocatable
7934 || arg
->symtree
->n
.sym
->attr
.pointer
)
7936 non_null_expr
= gfc_finish_block (&block
);
7937 gfc_start_block (&block
);
7938 gfc_conv_descriptor_data_set (&block
, dest
,
7940 null_expr
= gfc_finish_block (&block
);
7941 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7942 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7943 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7944 return build3_v (COND_EXPR
, tmp
,
7945 null_expr
, non_null_expr
);
7949 return gfc_finish_block (&block
);
7953 /* Allocate or reallocate scalar component, as necessary. */
7956 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7966 tree lhs_cl_size
= NULL_TREE
;
7971 if (!expr2
|| expr2
->rank
)
7974 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7976 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7978 char name
[GFC_MAX_SYMBOL_LEN
+9];
7979 gfc_component
*strlen
;
7980 /* Use the rhs string length and the lhs element size. */
7981 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7982 if (!expr2
->ts
.u
.cl
->backend_decl
)
7984 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7985 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7988 size
= expr2
->ts
.u
.cl
->backend_decl
;
7990 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7992 sprintf (name
, "_%s_length", cm
->name
);
7993 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7994 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7995 gfc_charlen_type_node
,
7996 TREE_OPERAND (comp
, 0),
7997 strlen
->backend_decl
, NULL_TREE
);
7999 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8000 tmp
= TYPE_SIZE_UNIT (tmp
);
8001 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8002 TREE_TYPE (tmp
), tmp
,
8003 fold_convert (TREE_TYPE (tmp
), size
));
8005 else if (cm
->ts
.type
== BT_CLASS
)
8007 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8008 if (expr2
->ts
.type
== BT_DERIVED
)
8010 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8011 size
= TYPE_SIZE_UNIT (tmp
);
8017 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8018 gfc_add_vptr_component (e2vtab
);
8019 gfc_add_size_component (e2vtab
);
8020 gfc_init_se (&se
, NULL
);
8021 gfc_conv_expr (&se
, e2vtab
);
8022 gfc_add_block_to_block (block
, &se
.pre
);
8023 size
= fold_convert (size_type_node
, se
.expr
);
8024 gfc_free_expr (e2vtab
);
8026 size_in_bytes
= size
;
8030 /* Otherwise use the length in bytes of the rhs. */
8031 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8032 size_in_bytes
= size
;
8035 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8036 size_in_bytes
, size_one_node
);
8038 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8040 tmp
= build_call_expr_loc (input_location
,
8041 builtin_decl_explicit (BUILT_IN_CALLOC
),
8042 2, build_one_cst (size_type_node
),
8044 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8045 gfc_add_modify (block
, comp
, tmp
);
8049 tmp
= build_call_expr_loc (input_location
,
8050 builtin_decl_explicit (BUILT_IN_MALLOC
),
8052 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8053 ptr
= gfc_class_data_get (comp
);
8056 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8057 gfc_add_modify (block
, ptr
, tmp
);
8060 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8061 /* Update the lhs character length. */
8062 gfc_add_modify (block
, lhs_cl_size
,
8063 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8067 /* Assign a single component of a derived type constructor. */
8070 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8071 gfc_symbol
*sym
, bool init
)
8079 gfc_start_block (&block
);
8081 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8083 /* Only care about pointers here, not about allocatables. */
8084 gfc_init_se (&se
, NULL
);
8085 /* Pointer component. */
8086 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8087 && !cm
->attr
.proc_pointer
)
8089 /* Array pointer. */
8090 if (expr
->expr_type
== EXPR_NULL
)
8091 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8094 se
.direct_byref
= 1;
8096 gfc_conv_expr_descriptor (&se
, expr
);
8097 gfc_add_block_to_block (&block
, &se
.pre
);
8098 gfc_add_block_to_block (&block
, &se
.post
);
8103 /* Scalar pointers. */
8104 se
.want_pointer
= 1;
8105 gfc_conv_expr (&se
, expr
);
8106 gfc_add_block_to_block (&block
, &se
.pre
);
8108 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8109 && expr
->symtree
->n
.sym
->attr
.dummy
)
8110 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8112 gfc_add_modify (&block
, dest
,
8113 fold_convert (TREE_TYPE (dest
), se
.expr
));
8114 gfc_add_block_to_block (&block
, &se
.post
);
8117 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8119 /* NULL initialization for CLASS components. */
8120 tmp
= gfc_trans_structure_assign (dest
,
8121 gfc_class_initializer (&cm
->ts
, expr
),
8123 gfc_add_expr_to_block (&block
, tmp
);
8125 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8126 && !cm
->attr
.proc_pointer
)
8128 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8129 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8130 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8132 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8133 gfc_add_expr_to_block (&block
, tmp
);
8137 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8138 gfc_add_expr_to_block (&block
, tmp
);
8141 else if (cm
->ts
.type
== BT_CLASS
8142 && CLASS_DATA (cm
)->attr
.dimension
8143 && CLASS_DATA (cm
)->attr
.allocatable
8144 && expr
->ts
.type
== BT_DERIVED
)
8146 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8147 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8148 tmp
= gfc_class_vptr_get (dest
);
8149 gfc_add_modify (&block
, tmp
,
8150 fold_convert (TREE_TYPE (tmp
), vtab
));
8151 tmp
= gfc_class_data_get (dest
);
8152 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8153 gfc_add_expr_to_block (&block
, tmp
);
8155 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8157 /* NULL initialization for allocatable components. */
8158 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8159 null_pointer_node
));
8161 else if (init
&& (cm
->attr
.allocatable
8162 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8163 && expr
->ts
.type
!= BT_CLASS
)))
8165 /* Take care about non-array allocatable components here. The alloc_*
8166 routine below is motivated by the alloc_scalar_allocatable_for_
8167 assignment() routine, but with the realloc portions removed and
8169 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8174 /* The remainder of these instructions follow the if (cm->attr.pointer)
8175 if (!cm->attr.dimension) part above. */
8176 gfc_init_se (&se
, NULL
);
8177 gfc_conv_expr (&se
, expr
);
8178 gfc_add_block_to_block (&block
, &se
.pre
);
8180 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8181 && expr
->symtree
->n
.sym
->attr
.dummy
)
8182 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8184 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8186 tmp
= gfc_class_data_get (dest
);
8187 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8188 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8189 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8190 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8191 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8194 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8196 /* For deferred strings insert a memcpy. */
8197 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8200 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8201 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8203 : expr
->ts
.u
.cl
->backend_decl
);
8204 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8205 gfc_add_expr_to_block (&block
, tmp
);
8208 gfc_add_modify (&block
, tmp
,
8209 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8210 gfc_add_block_to_block (&block
, &se
.post
);
8212 else if (expr
->ts
.type
== BT_UNION
)
8215 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8216 /* We mark that the entire union should be initialized with a contrived
8217 EXPR_NULL expression at the beginning. */
8218 if (c
!= NULL
&& c
->n
.component
== NULL
8219 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8221 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8222 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8223 gfc_add_expr_to_block (&block
, tmp
);
8224 c
= gfc_constructor_next (c
);
8226 /* The following constructor expression, if any, represents a specific
8227 map intializer, as given by the user. */
8228 if (c
!= NULL
&& c
->expr
!= NULL
)
8230 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8231 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8232 gfc_add_expr_to_block (&block
, tmp
);
8235 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8237 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8239 tree dealloc
= NULL_TREE
;
8240 gfc_init_se (&se
, NULL
);
8241 gfc_conv_expr (&se
, expr
);
8242 gfc_add_block_to_block (&block
, &se
.pre
);
8243 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8244 expression in a temporary variable and deallocate the allocatable
8245 components. Then we can the copy the expression to the result. */
8246 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8247 && expr
->expr_type
!= EXPR_VARIABLE
)
8249 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8250 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8253 gfc_add_modify (&block
, dest
,
8254 fold_convert (TREE_TYPE (dest
), se
.expr
));
8255 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8256 && expr
->expr_type
!= EXPR_NULL
)
8258 // TODO: Fix caf_mode
8259 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8260 dest
, expr
->rank
, 0);
8261 gfc_add_expr_to_block (&block
, tmp
);
8262 if (dealloc
!= NULL_TREE
)
8263 gfc_add_expr_to_block (&block
, dealloc
);
8265 gfc_add_block_to_block (&block
, &se
.post
);
8269 /* Nested constructors. */
8270 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8271 gfc_add_expr_to_block (&block
, tmp
);
8274 else if (gfc_deferred_strlen (cm
, &tmp
))
8278 gcc_assert (strlen
);
8279 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8281 TREE_OPERAND (dest
, 0),
8284 if (expr
->expr_type
== EXPR_NULL
)
8286 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
8287 gfc_add_modify (&block
, dest
, tmp
);
8288 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
8289 gfc_add_modify (&block
, strlen
, tmp
);
8294 gfc_init_se (&se
, NULL
);
8295 gfc_conv_expr (&se
, expr
);
8296 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
8297 tmp
= build_call_expr_loc (input_location
,
8298 builtin_decl_explicit (BUILT_IN_MALLOC
),
8300 gfc_add_modify (&block
, dest
,
8301 fold_convert (TREE_TYPE (dest
), tmp
));
8302 gfc_add_modify (&block
, strlen
,
8303 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
8304 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
8305 gfc_add_expr_to_block (&block
, tmp
);
8308 else if (!cm
->attr
.artificial
)
8310 /* Scalar component (excluding deferred parameters). */
8311 gfc_init_se (&se
, NULL
);
8312 gfc_init_se (&lse
, NULL
);
8314 gfc_conv_expr (&se
, expr
);
8315 if (cm
->ts
.type
== BT_CHARACTER
)
8316 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8318 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
8319 gfc_add_expr_to_block (&block
, tmp
);
8321 return gfc_finish_block (&block
);
8324 /* Assign a derived type constructor to a variable. */
8327 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
8336 gfc_start_block (&block
);
8338 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
8339 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
8340 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
8344 gfc_init_se (&se
, NULL
);
8345 gfc_init_se (&lse
, NULL
);
8346 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
8348 gfc_add_modify (&block
, lse
.expr
,
8349 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
8351 return gfc_finish_block (&block
);
8354 /* Make sure that the derived type has been completely built. */
8355 if (!expr
->ts
.u
.derived
->backend_decl
8356 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
8358 tmp
= gfc_typenode_for_spec (&expr
->ts
);
8362 cm
= expr
->ts
.u
.derived
->components
;
8366 gfc_init_se (&se
, NULL
);
8368 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8369 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8371 /* Skip absent members in default initializers. */
8372 if (!c
->expr
&& !cm
->attr
.allocatable
)
8375 /* Register the component with the caf-lib before it is initialized.
8376 Register only allocatable components, that are not coarray'ed
8377 components (%comp[*]). Only register when the constructor is not the
8379 if (coarray
&& !cm
->attr
.codimension
8380 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
8381 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
8383 tree token
, desc
, size
;
8384 bool is_array
= cm
->ts
.type
== BT_CLASS
8385 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
8387 field
= cm
->backend_decl
;
8388 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
8389 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
8390 if (cm
->ts
.type
== BT_CLASS
)
8391 field
= gfc_class_data_get (field
);
8393 token
= is_array
? gfc_conv_descriptor_token (field
)
8394 : fold_build3_loc (input_location
, COMPONENT_REF
,
8395 TREE_TYPE (cm
->caf_token
), dest
,
8396 cm
->caf_token
, NULL_TREE
);
8400 /* The _caf_register routine looks at the rank of the array
8401 descriptor to decide whether the data registered is an array
8403 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
8405 /* When the rank is not known just set a positive rank, which
8406 suffices to recognize the data as array. */
8409 size
= build_zero_cst (size_type_node
);
8411 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
8412 build_int_cst (signed_char_type_node
, rank
));
8416 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8417 cm
->ts
.type
== BT_CLASS
8418 ? CLASS_DATA (cm
)->attr
8420 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8422 gfc_add_block_to_block (&block
, &se
.pre
);
8423 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8424 7, size
, build_int_cst (
8426 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8427 gfc_build_addr_expr (pvoid_type_node
,
8429 gfc_build_addr_expr (NULL_TREE
, desc
),
8430 null_pointer_node
, null_pointer_node
,
8432 gfc_add_expr_to_block (&block
, tmp
);
8434 field
= cm
->backend_decl
;
8436 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8437 dest
, field
, NULL_TREE
);
8440 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8441 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8446 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8447 expr
->ts
.u
.derived
, init
);
8448 gfc_add_expr_to_block (&block
, tmp
);
8450 return gfc_finish_block (&block
);
8454 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8455 gfc_component
*un
, gfc_expr
*init
)
8457 gfc_constructor
*ctor
;
8459 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8462 ctor
= gfc_constructor_first (init
->value
.constructor
);
8464 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8467 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8469 /* If we have an 'initialize all' constructor, do it first. */
8470 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8472 tree union_type
= TREE_TYPE (un
->backend_decl
);
8473 tree val
= build_constructor (union_type
, NULL
);
8474 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8475 ctor
= gfc_constructor_next (ctor
);
8478 /* Add the map initializer on top. */
8479 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8481 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8482 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8483 TREE_TYPE (un
->backend_decl
),
8484 un
->attr
.dimension
, un
->attr
.pointer
,
8485 un
->attr
.proc_pointer
);
8486 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8490 /* Build an expression for a constructor. If init is nonzero then
8491 this is part of a static variable initializer. */
8494 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8501 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8503 gcc_assert (se
->ss
== NULL
);
8504 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8505 type
= gfc_typenode_for_spec (&expr
->ts
);
8509 /* Create a temporary variable and fill it in. */
8510 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8511 /* The symtree in expr is NULL, if the code to generate is for
8512 initializing the static members only. */
8513 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8515 gfc_add_expr_to_block (&se
->pre
, tmp
);
8519 cm
= expr
->ts
.u
.derived
->components
;
8521 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8522 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8524 /* Skip absent members in default initializers and allocatable
8525 components. Although the latter have a default initializer
8526 of EXPR_NULL,... by default, the static nullify is not needed
8527 since this is done every time we come into scope. */
8528 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8531 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8532 && strcmp (cm
->name
, "_extends") == 0
8533 && cm
->initializer
->symtree
)
8537 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8538 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8539 vtab
= unshare_expr_without_location (vtab
);
8540 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8542 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8544 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8545 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8546 fold_convert (TREE_TYPE (cm
->backend_decl
),
8549 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8550 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8551 fold_convert (TREE_TYPE (cm
->backend_decl
),
8552 integer_zero_node
));
8553 else if (cm
->ts
.type
== BT_UNION
)
8554 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8557 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8558 TREE_TYPE (cm
->backend_decl
),
8559 cm
->attr
.dimension
, cm
->attr
.pointer
,
8560 cm
->attr
.proc_pointer
);
8561 val
= unshare_expr_without_location (val
);
8563 /* Append it to the constructor list. */
8564 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8568 se
->expr
= build_constructor (type
, v
);
8570 TREE_CONSTANT (se
->expr
) = 1;
8574 /* Translate a substring expression. */
8577 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8583 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8585 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8586 expr
->value
.character
.length
,
8587 expr
->value
.character
.string
);
8589 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8590 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8593 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8597 /* Entry point for expression translation. Evaluates a scalar quantity.
8598 EXPR is the expression to be translated, and SE is the state structure if
8599 called from within the scalarized. */
8602 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8607 if (ss
&& ss
->info
->expr
== expr
8608 && (ss
->info
->type
== GFC_SS_SCALAR
8609 || ss
->info
->type
== GFC_SS_REFERENCE
))
8611 gfc_ss_info
*ss_info
;
8614 /* Substitute a scalar expression evaluated outside the scalarization
8616 se
->expr
= ss_info
->data
.scalar
.value
;
8617 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8618 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8620 se
->string_length
= ss_info
->string_length
;
8621 gfc_advance_se_ss_chain (se
);
8625 /* We need to convert the expressions for the iso_c_binding derived types.
8626 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8627 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8628 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8629 updated to be an integer with a kind equal to the size of a (void *). */
8630 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8631 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8633 if (expr
->expr_type
== EXPR_VARIABLE
8634 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8635 || expr
->symtree
->n
.sym
->intmod_sym_id
8636 == ISOCBINDING_NULL_FUNPTR
))
8638 /* Set expr_type to EXPR_NULL, which will result in
8639 null_pointer_node being used below. */
8640 expr
->expr_type
= EXPR_NULL
;
8644 /* Update the type/kind of the expression to be what the new
8645 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8646 expr
->ts
.type
= BT_INTEGER
;
8647 expr
->ts
.f90_type
= BT_VOID
;
8648 expr
->ts
.kind
= gfc_index_integer_kind
;
8652 gfc_fix_class_refs (expr
);
8654 switch (expr
->expr_type
)
8657 gfc_conv_expr_op (se
, expr
);
8661 gfc_conv_function_expr (se
, expr
);
8665 gfc_conv_constant (se
, expr
);
8669 gfc_conv_variable (se
, expr
);
8673 se
->expr
= null_pointer_node
;
8676 case EXPR_SUBSTRING
:
8677 gfc_conv_substring_expr (se
, expr
);
8680 case EXPR_STRUCTURE
:
8681 gfc_conv_structure (se
, expr
, 0);
8685 gfc_conv_array_constructor_expr (se
, expr
);
8694 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8695 of an assignment. */
8697 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8699 gfc_conv_expr (se
, expr
);
8700 /* All numeric lvalues should have empty post chains. If not we need to
8701 figure out a way of rewriting an lvalue so that it has no post chain. */
8702 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8705 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8706 numeric expressions. Used for scalar values where inserting cleanup code
8709 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8713 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8714 gfc_conv_expr (se
, expr
);
8717 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8718 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8720 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8724 /* Helper to translate an expression and convert it to a particular type. */
8726 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8728 gfc_conv_expr_val (se
, expr
);
8729 se
->expr
= convert (type
, se
->expr
);
8733 /* Converts an expression so that it can be passed by reference. Scalar
8737 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8743 if (ss
&& ss
->info
->expr
== expr
8744 && ss
->info
->type
== GFC_SS_REFERENCE
)
8746 /* Returns a reference to the scalar evaluated outside the loop
8748 gfc_conv_expr (se
, expr
);
8750 if (expr
->ts
.type
== BT_CHARACTER
8751 && expr
->expr_type
!= EXPR_FUNCTION
)
8752 gfc_conv_string_parameter (se
);
8754 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8759 if (expr
->ts
.type
== BT_CHARACTER
)
8761 gfc_conv_expr (se
, expr
);
8762 gfc_conv_string_parameter (se
);
8766 if (expr
->expr_type
== EXPR_VARIABLE
)
8768 se
->want_pointer
= 1;
8769 gfc_conv_expr (se
, expr
);
8772 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8773 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8774 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8777 else if (add_clobber
&& expr
->ref
== NULL
)
8781 /* FIXME: This fails if var is passed by reference, see PR
8783 var
= expr
->symtree
->n
.sym
->backend_decl
;
8784 clobber
= build_clobber (TREE_TYPE (var
));
8785 gfc_add_modify (&se
->pre
, var
, clobber
);
8790 if (expr
->expr_type
== EXPR_FUNCTION
8791 && ((expr
->value
.function
.esym
8792 && expr
->value
.function
.esym
->result
->attr
.pointer
8793 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8794 || (!expr
->value
.function
.esym
&& !expr
->ref
8795 && expr
->symtree
->n
.sym
->attr
.pointer
8796 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8798 se
->want_pointer
= 1;
8799 gfc_conv_expr (se
, expr
);
8800 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8801 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8806 gfc_conv_expr (se
, expr
);
8808 /* Create a temporary var to hold the value. */
8809 if (TREE_CONSTANT (se
->expr
))
8811 tree tmp
= se
->expr
;
8812 STRIP_TYPE_NOPS (tmp
);
8813 var
= build_decl (input_location
,
8814 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8815 DECL_INITIAL (var
) = tmp
;
8816 TREE_STATIC (var
) = 1;
8821 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8822 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8825 if (!expr
->must_finalize
)
8826 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8828 /* Take the address of that value. */
8829 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8833 /* Get the _len component for an unlimited polymorphic expression. */
8836 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8839 gfc_ref
*ref
= expr
->ref
;
8841 gfc_init_se (&se
, NULL
);
8842 while (ref
&& ref
->next
)
8844 gfc_add_len_component (expr
);
8845 gfc_conv_expr (&se
, expr
);
8846 gfc_add_block_to_block (block
, &se
.pre
);
8847 gcc_assert (se
.post
.head
== NULL_TREE
);
8850 gfc_free_ref_list (ref
->next
);
8855 gfc_free_ref_list (expr
->ref
);
8862 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8863 statement-list outside of the scalarizer-loop. When code is generated, that
8864 depends on the scalarized expression, it is added to RSE.PRE.
8865 Returns le's _vptr tree and when set the len expressions in to_lenp and
8866 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8870 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8871 gfc_expr
* re
, gfc_se
*rse
,
8872 tree
* to_lenp
, tree
* from_lenp
)
8875 gfc_expr
* vptr_expr
;
8876 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8877 bool set_vptr
= false, temp_rhs
= false;
8878 stmtblock_t
*pre
= block
;
8880 /* Create a temporary for complicated expressions. */
8881 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8882 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8884 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8886 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8891 /* Get the _vptr for the left-hand side expression. */
8892 gfc_init_se (&se
, NULL
);
8893 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8894 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8896 /* Care about _len for unlimited polymorphic entities. */
8897 if (UNLIMITED_POLY (vptr_expr
)
8898 || (vptr_expr
->ts
.type
== BT_DERIVED
8899 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8900 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8901 gfc_add_vptr_component (vptr_expr
);
8905 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8906 se
.want_pointer
= 1;
8907 gfc_conv_expr (&se
, vptr_expr
);
8908 gfc_free_expr (vptr_expr
);
8909 gfc_add_block_to_block (block
, &se
.pre
);
8910 gcc_assert (se
.post
.head
== NULL_TREE
);
8912 STRIP_NOPS (lhs_vptr
);
8914 /* Set the _vptr only when the left-hand side of the assignment is a
8918 /* Get the vptr from the rhs expression only, when it is variable.
8919 Functions are expected to be assigned to a temporary beforehand. */
8920 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8921 ? gfc_find_and_cut_at_last_class_ref (re
)
8923 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8925 if (to_len
!= NULL_TREE
)
8927 /* Get the _len information from the rhs. */
8928 if (UNLIMITED_POLY (vptr_expr
)
8929 || (vptr_expr
->ts
.type
== BT_DERIVED
8930 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8931 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8933 gfc_add_vptr_component (vptr_expr
);
8937 if (re
->expr_type
== EXPR_VARIABLE
8938 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8939 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8940 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8941 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8942 re
->symtree
->n
.sym
->backend_decl
))))
8945 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8946 re
->symtree
->n
.sym
->backend_decl
));
8948 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8949 re
->symtree
->n
.sym
->backend_decl
));
8951 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8954 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8955 if (UNLIMITED_POLY (re
))
8956 from_len
= gfc_class_len_get (rse
->expr
);
8958 else if (re
->expr_type
!= EXPR_NULL
)
8959 /* Only when rhs is non-NULL use its declared type for vptr
8961 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8963 /* When the rhs is NULL use the vtab of lhs' declared type. */
8964 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8969 gfc_init_se (&se
, NULL
);
8970 se
.want_pointer
= 1;
8971 gfc_conv_expr (&se
, vptr_expr
);
8972 gfc_free_expr (vptr_expr
);
8973 gfc_add_block_to_block (block
, &se
.pre
);
8974 gcc_assert (se
.post
.head
== NULL_TREE
);
8976 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8979 if (to_len
!= NULL_TREE
)
8981 /* The _len component needs to be set. Figure how to get the
8982 value of the right-hand side. */
8983 if (from_len
== NULL_TREE
)
8985 if (rse
->string_length
!= NULL_TREE
)
8986 from_len
= rse
->string_length
;
8987 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8989 gfc_init_se (&se
, NULL
);
8990 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8991 gfc_add_block_to_block (block
, &se
.pre
);
8992 gcc_assert (se
.post
.head
== NULL_TREE
);
8993 from_len
= gfc_evaluate_now (se
.expr
, block
);
8996 from_len
= build_zero_cst (gfc_charlen_type_node
);
8998 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9003 /* Return the _len trees only, when requested. */
9007 *from_lenp
= from_len
;
9012 /* Assign tokens for pointer components. */
9015 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9018 symbol_attribute lhs_attr
, rhs_attr
;
9019 tree tmp
, lhs_tok
, rhs_tok
;
9020 /* Flag to indicated component refs on the rhs. */
9023 lhs_attr
= gfc_caf_attr (expr1
);
9024 if (expr2
->expr_type
!= EXPR_NULL
)
9026 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9027 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9029 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9030 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9033 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9037 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9038 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9041 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9043 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9044 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9047 else if (lhs_attr
.codimension
)
9049 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9050 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9051 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9052 lhs_tok
, null_pointer_node
);
9053 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9058 /* Do everything that is needed for a CLASS function expr2. */
9061 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9062 gfc_expr
*expr1
, gfc_expr
*expr2
)
9064 tree expr1_vptr
= NULL_TREE
;
9067 gfc_conv_function_expr (rse
, expr2
);
9068 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9070 if (expr1
->ts
.type
!= BT_CLASS
)
9071 rse
->expr
= gfc_class_data_get (rse
->expr
);
9074 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9077 gfc_add_block_to_block (block
, &rse
->pre
);
9078 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9079 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9081 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9082 fold_convert (TREE_TYPE (expr1_vptr
),
9083 gfc_class_vptr_get (tmp
)));
9084 rse
->expr
= gfc_class_data_get (tmp
);
9092 gfc_trans_pointer_assign (gfc_code
* code
)
9094 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9098 /* Generate code for a pointer assignment. */
9101 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9108 tree expr1_vptr
= NULL_TREE
;
9109 bool scalar
, non_proc_ptr_assign
;
9112 gfc_start_block (&block
);
9114 gfc_init_se (&lse
, NULL
);
9116 /* Usually testing whether this is not a proc pointer assignment. */
9117 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9118 && expr2
->expr_type
== EXPR_VARIABLE
9119 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9121 /* Check whether the expression is a scalar or not; we cannot use
9122 expr1->rank as it can be nonzero for proc pointers. */
9123 ss
= gfc_walk_expr (expr1
);
9124 scalar
= ss
== gfc_ss_terminator
;
9126 gfc_free_ss_chain (ss
);
9128 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9129 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9131 gfc_add_data_component (expr2
);
9132 /* The following is required as gfc_add_data_component doesn't
9133 update ts.type if there is a tailing REF_ARRAY. */
9134 expr2
->ts
.type
= BT_DERIVED
;
9139 /* Scalar pointers. */
9140 lse
.want_pointer
= 1;
9141 gfc_conv_expr (&lse
, expr1
);
9142 gfc_init_se (&rse
, NULL
);
9143 rse
.want_pointer
= 1;
9144 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9145 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9147 gfc_conv_expr (&rse
, expr2
);
9149 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9151 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9153 lse
.expr
= gfc_class_data_get (lse
.expr
);
9156 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9157 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9158 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9161 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9162 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9163 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9166 gfc_add_block_to_block (&block
, &lse
.pre
);
9167 gfc_add_block_to_block (&block
, &rse
.pre
);
9169 /* Check character lengths if character expression. The test is only
9170 really added if -fbounds-check is enabled. Exclude deferred
9171 character length lefthand sides. */
9172 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9173 && !expr1
->ts
.deferred
9174 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9175 && !gfc_is_proc_ptr_comp (expr1
))
9177 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9178 gcc_assert (lse
.string_length
&& rse
.string_length
);
9179 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9180 lse
.string_length
, rse
.string_length
,
9184 /* The assignment to an deferred character length sets the string
9185 length to that of the rhs. */
9186 if (expr1
->ts
.deferred
)
9188 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9189 gfc_add_modify (&block
, lse
.string_length
,
9190 fold_convert (TREE_TYPE (lse
.string_length
),
9191 rse
.string_length
));
9192 else if (lse
.string_length
!= NULL
)
9193 gfc_add_modify (&block
, lse
.string_length
,
9194 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9197 gfc_add_modify (&block
, lse
.expr
,
9198 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9200 /* Also set the tokens for pointer components in derived typed
9202 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9203 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9205 gfc_add_block_to_block (&block
, &rse
.post
);
9206 gfc_add_block_to_block (&block
, &lse
.post
);
9213 tree strlen_rhs
= NULL_TREE
;
9215 /* Array pointer. Find the last reference on the LHS and if it is an
9216 array section ref, we're dealing with bounds remapping. In this case,
9217 set it to AR_FULL so that gfc_conv_expr_descriptor does
9218 not see it and process the bounds remapping afterwards explicitly. */
9219 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9220 if (!remap
->next
&& remap
->type
== REF_ARRAY
9221 && remap
->u
.ar
.type
== AR_SECTION
)
9223 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9225 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
9227 gfc_error ("If bounds remapping is specified at %L, "
9228 "the pointer target shall not be NULL", &expr1
->where
);
9232 gfc_init_se (&lse
, NULL
);
9234 lse
.descriptor_only
= 1;
9235 gfc_conv_expr_descriptor (&lse
, expr1
);
9236 strlen_lhs
= lse
.string_length
;
9239 if (expr2
->expr_type
== EXPR_NULL
)
9241 /* Just set the data pointer to null. */
9242 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9244 else if (rank_remap
)
9246 /* If we are rank-remapping, just get the RHS's descriptor and
9247 process this later on. */
9248 gfc_init_se (&rse
, NULL
);
9249 rse
.direct_byref
= 1;
9250 rse
.byref_noassign
= 1;
9252 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9253 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
9255 else if (expr2
->expr_type
== EXPR_FUNCTION
)
9257 tree bound
[GFC_MAX_DIMENSIONS
];
9260 for (i
= 0; i
< expr2
->rank
; i
++)
9261 bound
[i
] = NULL_TREE
;
9262 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
9263 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
9265 GFC_ARRAY_POINTER_CONT
, false);
9266 tmp
= gfc_create_var (tmp
, "ptrtemp");
9267 rse
.descriptor_only
= 0;
9269 rse
.direct_byref
= 1;
9270 gfc_conv_expr_descriptor (&rse
, expr2
);
9271 strlen_rhs
= rse
.string_length
;
9276 gfc_conv_expr_descriptor (&rse
, expr2
);
9277 strlen_rhs
= rse
.string_length
;
9278 if (expr1
->ts
.type
== BT_CLASS
)
9279 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9284 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9286 /* Assign directly to the LHS's descriptor. */
9287 lse
.descriptor_only
= 0;
9288 lse
.direct_byref
= 1;
9289 gfc_conv_expr_descriptor (&lse
, expr2
);
9290 strlen_rhs
= lse
.string_length
;
9292 if (expr1
->ts
.type
== BT_CLASS
)
9294 rse
.expr
= NULL_TREE
;
9295 rse
.string_length
= NULL_TREE
;
9296 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
9302 /* If the target is not a whole array, use the target array
9303 reference for remap. */
9304 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
9305 if (remap
->type
== REF_ARRAY
9306 && remap
->u
.ar
.type
== AR_FULL
9311 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9313 gfc_init_se (&rse
, NULL
);
9314 rse
.want_pointer
= 1;
9315 gfc_conv_function_expr (&rse
, expr2
);
9316 if (expr1
->ts
.type
!= BT_CLASS
)
9318 rse
.expr
= gfc_class_data_get (rse
.expr
);
9319 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9320 /* Set the lhs span. */
9321 tmp
= TREE_TYPE (rse
.expr
);
9322 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9323 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9324 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
9328 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9331 gfc_add_block_to_block (&block
, &rse
.pre
);
9332 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
9333 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
9335 gfc_add_modify (&lse
.pre
, expr1_vptr
,
9336 fold_convert (TREE_TYPE (expr1_vptr
),
9337 gfc_class_vptr_get (tmp
)));
9338 rse
.expr
= gfc_class_data_get (tmp
);
9339 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9344 /* Assign to a temporary descriptor and then copy that
9345 temporary to the pointer. */
9346 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
9347 lse
.descriptor_only
= 0;
9349 lse
.direct_byref
= 1;
9350 gfc_conv_expr_descriptor (&lse
, expr2
);
9351 strlen_rhs
= lse
.string_length
;
9352 gfc_add_modify (&lse
.pre
, desc
, tmp
);
9355 gfc_add_block_to_block (&block
, &lse
.pre
);
9357 gfc_add_block_to_block (&block
, &rse
.pre
);
9359 /* If we do bounds remapping, update LHS descriptor accordingly. */
9363 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
9367 /* Do rank remapping. We already have the RHS's descriptor
9368 converted in rse and now have to build the correct LHS
9369 descriptor for it. */
9371 tree dtype
, data
, span
;
9373 tree lbound
, ubound
;
9376 dtype
= gfc_conv_descriptor_dtype (desc
);
9377 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
9378 gfc_add_modify (&block
, dtype
, tmp
);
9380 /* Copy data pointer. */
9381 data
= gfc_conv_descriptor_data_get (rse
.expr
);
9382 gfc_conv_descriptor_data_set (&block
, desc
, data
);
9384 /* Copy the span. */
9385 if (TREE_CODE (rse
.expr
) == VAR_DECL
9386 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
9387 span
= gfc_conv_descriptor_span_get (rse
.expr
);
9390 tmp
= TREE_TYPE (rse
.expr
);
9391 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9392 span
= fold_convert (gfc_array_index_type
, tmp
);
9394 gfc_conv_descriptor_span_set (&block
, desc
, span
);
9396 /* Copy offset but adjust it such that it would correspond
9397 to a lbound of zero. */
9398 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
9399 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
9401 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9403 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
9405 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9406 gfc_array_index_type
, stride
, lbound
);
9407 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9408 gfc_array_index_type
, offs
, tmp
);
9410 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9412 /* Set the bounds as declared for the LHS and calculate strides as
9413 well as another offset update accordingly. */
9414 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9416 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9421 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9423 /* Convert declared bounds. */
9424 gfc_init_se (&lower_se
, NULL
);
9425 gfc_init_se (&upper_se
, NULL
);
9426 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9427 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9429 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9430 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9432 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9433 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9435 lbound
= gfc_evaluate_now (lbound
, &block
);
9436 ubound
= gfc_evaluate_now (ubound
, &block
);
9438 gfc_add_block_to_block (&block
, &lower_se
.post
);
9439 gfc_add_block_to_block (&block
, &upper_se
.post
);
9441 /* Set bounds in descriptor. */
9442 gfc_conv_descriptor_lbound_set (&block
, desc
,
9443 gfc_rank_cst
[dim
], lbound
);
9444 gfc_conv_descriptor_ubound_set (&block
, desc
,
9445 gfc_rank_cst
[dim
], ubound
);
9448 stride
= gfc_evaluate_now (stride
, &block
);
9449 gfc_conv_descriptor_stride_set (&block
, desc
,
9450 gfc_rank_cst
[dim
], stride
);
9452 /* Update offset. */
9453 offs
= gfc_conv_descriptor_offset_get (desc
);
9454 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9455 gfc_array_index_type
, lbound
, stride
);
9456 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9457 gfc_array_index_type
, offs
, tmp
);
9458 offs
= gfc_evaluate_now (offs
, &block
);
9459 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9461 /* Update stride. */
9462 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9463 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9464 gfc_array_index_type
, stride
, tmp
);
9469 /* Bounds remapping. Just shift the lower bounds. */
9471 gcc_assert (expr1
->rank
== expr2
->rank
);
9473 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9477 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9478 gfc_init_se (&lbound_se
, NULL
);
9479 if (remap
->u
.ar
.start
[dim
])
9481 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9482 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9485 /* This remap arises from a target that is not a whole
9486 array. The start expressions will be NULL but we need
9487 the lbounds to be one. */
9488 lbound_se
.expr
= gfc_index_one_node
;
9489 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9490 dim
, lbound_se
.expr
);
9491 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9496 /* If rank remapping was done, check with -fcheck=bounds that
9497 the target is at least as large as the pointer. */
9498 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9504 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9505 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9507 lsize
= gfc_evaluate_now (lsize
, &block
);
9508 rsize
= gfc_evaluate_now (rsize
, &block
);
9509 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9512 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9513 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9517 if (expr1
->ts
.type
== BT_CHARACTER
9518 && expr1
->symtree
->n
.sym
->ts
.deferred
9519 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9520 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9522 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9523 if (expr2
->expr_type
!= EXPR_NULL
)
9524 gfc_add_modify (&block
, tmp
,
9525 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9527 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9530 /* Check string lengths if applicable. The check is only really added
9531 to the output code if -fbounds-check is enabled. */
9532 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9534 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9535 gcc_assert (strlen_lhs
&& strlen_rhs
);
9536 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9537 strlen_lhs
, strlen_rhs
, &block
);
9540 gfc_add_block_to_block (&block
, &lse
.post
);
9542 gfc_add_block_to_block (&block
, &rse
.post
);
9545 return gfc_finish_block (&block
);
9549 /* Makes sure se is suitable for passing as a function string parameter. */
9550 /* TODO: Need to check all callers of this function. It may be abused. */
9553 gfc_conv_string_parameter (gfc_se
* se
)
9557 if (TREE_CODE (se
->expr
) == STRING_CST
)
9559 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9560 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9564 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
9565 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
9566 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9568 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9570 type
= TREE_TYPE (se
->expr
);
9571 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9575 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9577 type
= build_pointer_type (type
);
9578 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9582 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9586 /* Generate code for assignment of scalar variables. Includes character
9587 strings and derived types with allocatable components.
9588 If you know that the LHS has no allocations, set dealloc to false.
9590 DEEP_COPY has no effect if the typespec TS is not a derived type with
9591 allocatable components. Otherwise, if it is set, an explicit copy of each
9592 allocatable component is made. This is necessary as a simple copy of the
9593 whole object would copy array descriptors as is, so that the lhs's
9594 allocatable components would point to the rhs's after the assignment.
9595 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9596 necessary if the rhs is a non-pointer function, as the allocatable components
9597 are not accessible by other means than the function's result after the
9598 function has returned. It is even more subtle when temporaries are involved,
9599 as the two following examples show:
9600 1. When we evaluate an array constructor, a temporary is created. Thus
9601 there is theoretically no alias possible. However, no deep copy is
9602 made for this temporary, so that if the constructor is made of one or
9603 more variable with allocatable components, those components still point
9604 to the variable's: DEEP_COPY should be set for the assignment from the
9605 temporary to the lhs in that case.
9606 2. When assigning a scalar to an array, we evaluate the scalar value out
9607 of the loop, store it into a temporary variable, and assign from that.
9608 In that case, deep copying when assigning to the temporary would be a
9609 waste of resources; however deep copies should happen when assigning from
9610 the temporary to each array element: again DEEP_COPY should be set for
9611 the assignment from the temporary to the lhs. */
9614 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9615 bool deep_copy
, bool dealloc
, bool in_coarray
)
9621 gfc_init_block (&block
);
9623 if (ts
.type
== BT_CHARACTER
)
9628 if (lse
->string_length
!= NULL_TREE
)
9630 gfc_conv_string_parameter (lse
);
9631 gfc_add_block_to_block (&block
, &lse
->pre
);
9632 llen
= lse
->string_length
;
9635 if (rse
->string_length
!= NULL_TREE
)
9637 gfc_conv_string_parameter (rse
);
9638 gfc_add_block_to_block (&block
, &rse
->pre
);
9639 rlen
= rse
->string_length
;
9642 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9643 rse
->expr
, ts
.kind
);
9645 else if (gfc_bt_struct (ts
.type
)
9646 && (ts
.u
.derived
->attr
.alloc_comp
9647 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9649 tree tmp_var
= NULL_TREE
;
9652 /* Are the rhs and the lhs the same? */
9655 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9656 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9657 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9658 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9661 /* Deallocate the lhs allocated components as long as it is not
9662 the same as the rhs. This must be done following the assignment
9663 to prevent deallocating data that could be used in the rhs
9667 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9668 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9670 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9672 gfc_add_expr_to_block (&lse
->post
, tmp
);
9675 gfc_add_block_to_block (&block
, &rse
->pre
);
9676 gfc_add_block_to_block (&block
, &lse
->pre
);
9678 gfc_add_modify (&block
, lse
->expr
,
9679 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9681 /* Restore pointer address of coarray components. */
9682 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9684 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9685 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9687 gfc_add_expr_to_block (&block
, tmp
);
9690 /* Do a deep copy if the rhs is a variable, if it is not the
9694 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9695 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9696 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9698 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9700 gfc_add_expr_to_block (&block
, tmp
);
9703 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
9705 gfc_add_block_to_block (&block
, &lse
->pre
);
9706 gfc_add_block_to_block (&block
, &rse
->pre
);
9707 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9708 TREE_TYPE (lse
->expr
), rse
->expr
);
9709 gfc_add_modify (&block
, lse
->expr
, tmp
);
9713 gfc_add_block_to_block (&block
, &lse
->pre
);
9714 gfc_add_block_to_block (&block
, &rse
->pre
);
9716 gfc_add_modify (&block
, lse
->expr
,
9717 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9720 gfc_add_block_to_block (&block
, &lse
->post
);
9721 gfc_add_block_to_block (&block
, &rse
->post
);
9723 return gfc_finish_block (&block
);
9727 /* There are quite a lot of restrictions on the optimisation in using an
9728 array function assign without a temporary. */
9731 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9734 bool seen_array_ref
;
9736 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9738 /* Play it safe with class functions assigned to a derived type. */
9739 if (gfc_is_class_array_function (expr2
)
9740 && expr1
->ts
.type
== BT_DERIVED
)
9743 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9744 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9747 /* Elemental functions are scalarized so that they don't need a
9748 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9749 they would need special treatment in gfc_trans_arrayfunc_assign. */
9750 if (expr2
->value
.function
.esym
!= NULL
9751 && expr2
->value
.function
.esym
->attr
.elemental
)
9754 /* Need a temporary if rhs is not FULL or a contiguous section. */
9755 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9758 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9759 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9762 /* Functions returning pointers or allocatables need temporaries. */
9763 c
= expr2
->value
.function
.esym
9764 ? (expr2
->value
.function
.esym
->attr
.pointer
9765 || expr2
->value
.function
.esym
->attr
.allocatable
)
9766 : (expr2
->symtree
->n
.sym
->attr
.pointer
9767 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9771 /* Character array functions need temporaries unless the
9772 character lengths are the same. */
9773 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9775 if (expr1
->ts
.u
.cl
->length
== NULL
9776 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9779 if (expr2
->ts
.u
.cl
->length
== NULL
9780 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9783 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9784 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9788 /* Check that no LHS component references appear during an array
9789 reference. This is needed because we do not have the means to
9790 span any arbitrary stride with an array descriptor. This check
9791 is not needed for the rhs because the function result has to be
9793 seen_array_ref
= false;
9794 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9796 if (ref
->type
== REF_ARRAY
)
9797 seen_array_ref
= true;
9798 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9802 /* Check for a dependency. */
9803 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9804 expr2
->value
.function
.esym
,
9805 expr2
->value
.function
.actual
,
9809 /* If we have reached here with an intrinsic function, we do not
9810 need a temporary except in the particular case that reallocation
9811 on assignment is active and the lhs is allocatable and a target. */
9812 if (expr2
->value
.function
.isym
)
9813 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9815 /* If the LHS is a dummy, we need a temporary if it is not
9817 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9820 /* If the lhs has been host_associated, is in common, a pointer or is
9821 a target and the function is not using a RESULT variable, aliasing
9822 can occur and a temporary is needed. */
9823 if ((sym
->attr
.host_assoc
9824 || sym
->attr
.in_common
9825 || sym
->attr
.pointer
9826 || sym
->attr
.cray_pointee
9827 || sym
->attr
.target
)
9828 && expr2
->symtree
!= NULL
9829 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9832 /* A PURE function can unconditionally be called without a temporary. */
9833 if (expr2
->value
.function
.esym
!= NULL
9834 && expr2
->value
.function
.esym
->attr
.pure
)
9837 /* Implicit_pure functions are those which could legally be declared
9839 if (expr2
->value
.function
.esym
!= NULL
9840 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9843 if (!sym
->attr
.use_assoc
9844 && !sym
->attr
.in_common
9845 && !sym
->attr
.pointer
9846 && !sym
->attr
.target
9847 && !sym
->attr
.cray_pointee
9848 && expr2
->value
.function
.esym
)
9850 /* A temporary is not needed if the function is not contained and
9851 the variable is local or host associated and not a pointer or
9853 if (!expr2
->value
.function
.esym
->attr
.contained
)
9856 /* A temporary is not needed if the lhs has never been host
9857 associated and the procedure is contained. */
9858 else if (!sym
->attr
.host_assoc
)
9861 /* A temporary is not needed if the variable is local and not
9862 a pointer, a target or a result. */
9864 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9868 /* Default to temporary use. */
9873 /* Provide the loop info so that the lhs descriptor can be built for
9874 reallocatable assignments from extrinsic function calls. */
9877 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9880 /* Signal that the function call should not be made by
9881 gfc_conv_loop_setup. */
9882 se
->ss
->is_alloc_lhs
= 1;
9883 gfc_init_loopinfo (loop
);
9884 gfc_add_ss_to_loop (loop
, *ss
);
9885 gfc_add_ss_to_loop (loop
, se
->ss
);
9886 gfc_conv_ss_startstride (loop
);
9887 gfc_conv_loop_setup (loop
, where
);
9888 gfc_copy_loopinfo_to_se (se
, loop
);
9889 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9890 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9891 se
->ss
->is_alloc_lhs
= 0;
9895 /* For assignment to a reallocatable lhs from intrinsic functions,
9896 replace the se.expr (ie. the result) with a temporary descriptor.
9897 Null the data field so that the library allocates space for the
9898 result. Free the data of the original descriptor after the function,
9899 in case it appears in an argument expression and transfer the
9900 result to the original descriptor. */
9903 fcncall_realloc_result (gfc_se
*se
, int rank
)
9912 /* Use the allocation done by the library. Substitute the lhs
9913 descriptor with a copy, whose data field is nulled.*/
9914 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9915 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9916 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9918 /* Unallocated, the descriptor does not have a dtype. */
9919 tmp
= gfc_conv_descriptor_dtype (desc
);
9920 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9922 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9923 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9924 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9926 /* Free the lhs after the function call and copy the result data to
9927 the lhs descriptor. */
9928 tmp
= gfc_conv_descriptor_data_get (desc
);
9929 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9930 logical_type_node
, tmp
,
9931 build_int_cst (TREE_TYPE (tmp
), 0));
9932 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9933 tmp
= gfc_call_free (tmp
);
9934 gfc_add_expr_to_block (&se
->post
, tmp
);
9936 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9937 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9939 /* Check that the shapes are the same between lhs and expression. */
9940 for (n
= 0 ; n
< rank
; n
++)
9943 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9944 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9945 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9946 gfc_array_index_type
, tmp
, tmp1
);
9947 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9948 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9949 gfc_array_index_type
, tmp
, tmp1
);
9950 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9951 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9952 gfc_array_index_type
, tmp
, tmp1
);
9953 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9954 logical_type_node
, tmp
,
9955 gfc_index_zero_node
);
9956 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9957 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9958 logical_type_node
, tmp
,
9962 /* 'zero_cond' being true is equal to lhs not being allocated or the
9963 shapes being different. */
9964 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9966 /* Now reset the bounds returned from the function call to bounds based
9967 on the lhs lbounds, except where the lhs is not allocated or the shapes
9968 of 'variable and 'expr' are different. Set the offset accordingly. */
9969 offset
= gfc_index_zero_node
;
9970 for (n
= 0 ; n
< rank
; n
++)
9974 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9975 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9976 gfc_array_index_type
, zero_cond
,
9977 gfc_index_one_node
, lbound
);
9978 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9980 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9981 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9982 gfc_array_index_type
, tmp
, lbound
);
9983 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9984 gfc_rank_cst
[n
], lbound
);
9985 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9986 gfc_rank_cst
[n
], tmp
);
9988 /* Set stride and accumulate the offset. */
9989 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9990 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9991 gfc_rank_cst
[n
], tmp
);
9992 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9993 gfc_array_index_type
, lbound
, tmp
);
9994 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9995 gfc_array_index_type
, offset
, tmp
);
9996 offset
= gfc_evaluate_now (offset
, &se
->post
);
9999 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10004 /* Try to translate array(:) = func (...), where func is a transformational
10005 array function, without using a temporary. Returns NULL if this isn't the
10009 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10013 gfc_component
*comp
= NULL
;
10016 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10019 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10021 comp
= gfc_get_proc_ptr_comp (expr2
);
10023 if (!(expr2
->value
.function
.isym
10024 || (comp
&& comp
->attr
.dimension
)
10025 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10026 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10029 gfc_init_se (&se
, NULL
);
10030 gfc_start_block (&se
.pre
);
10031 se
.want_pointer
= 1;
10033 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10035 if (expr1
->ts
.type
== BT_DERIVED
10036 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10039 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10041 gfc_add_expr_to_block (&se
.pre
, tmp
);
10044 se
.direct_byref
= 1;
10045 se
.ss
= gfc_walk_expr (expr2
);
10046 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10048 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10049 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10050 Clearly, this cannot be done for an allocatable function result, since
10051 the shape of the result is unknown and, in any case, the function must
10052 correctly take care of the reallocation internally. For intrinsic
10053 calls, the array data is freed and the library takes care of allocation.
10054 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10056 if (flag_realloc_lhs
10057 && gfc_is_reallocatable_lhs (expr1
)
10058 && !gfc_expr_attr (expr1
).codimension
10059 && !gfc_is_coindexed (expr1
)
10060 && !(expr2
->value
.function
.esym
10061 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10063 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10065 if (!expr2
->value
.function
.isym
)
10067 ss
= gfc_walk_expr (expr1
);
10068 gcc_assert (ss
!= gfc_ss_terminator
);
10070 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10071 ss
->is_alloc_lhs
= 1;
10074 fcncall_realloc_result (&se
, expr1
->rank
);
10077 gfc_conv_function_expr (&se
, expr2
);
10078 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10081 gfc_cleanup_loop (&loop
);
10083 gfc_free_ss_chain (se
.ss
);
10085 return gfc_finish_block (&se
.pre
);
10089 /* Try to efficiently translate array(:) = 0. Return NULL if this
10093 gfc_trans_zero_assign (gfc_expr
* expr
)
10095 tree dest
, len
, type
;
10099 sym
= expr
->symtree
->n
.sym
;
10100 dest
= gfc_get_symbol_decl (sym
);
10102 type
= TREE_TYPE (dest
);
10103 if (POINTER_TYPE_P (type
))
10104 type
= TREE_TYPE (type
);
10105 if (!GFC_ARRAY_TYPE_P (type
))
10108 /* Determine the length of the array. */
10109 len
= GFC_TYPE_ARRAY_SIZE (type
);
10110 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10113 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10114 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10115 fold_convert (gfc_array_index_type
, tmp
));
10117 /* If we are zeroing a local array avoid taking its address by emitting
10119 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10120 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10121 dest
, build_constructor (TREE_TYPE (dest
),
10124 /* Convert arguments to the correct types. */
10125 dest
= fold_convert (pvoid_type_node
, dest
);
10126 len
= fold_convert (size_type_node
, len
);
10128 /* Construct call to __builtin_memset. */
10129 tmp
= build_call_expr_loc (input_location
,
10130 builtin_decl_explicit (BUILT_IN_MEMSET
),
10131 3, dest
, integer_zero_node
, len
);
10132 return fold_convert (void_type_node
, tmp
);
10136 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10137 that constructs the call to __builtin_memcpy. */
10140 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10144 /* Convert arguments to the correct types. */
10145 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10146 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10148 dst
= fold_convert (pvoid_type_node
, dst
);
10150 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10151 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10153 src
= fold_convert (pvoid_type_node
, src
);
10155 len
= fold_convert (size_type_node
, len
);
10157 /* Construct call to __builtin_memcpy. */
10158 tmp
= build_call_expr_loc (input_location
,
10159 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10161 return fold_convert (void_type_node
, tmp
);
10165 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10166 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10167 source/rhs, both are gfc_full_array_ref_p which have been checked for
10171 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10173 tree dst
, dlen
, dtype
;
10174 tree src
, slen
, stype
;
10177 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10178 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10180 dtype
= TREE_TYPE (dst
);
10181 if (POINTER_TYPE_P (dtype
))
10182 dtype
= TREE_TYPE (dtype
);
10183 stype
= TREE_TYPE (src
);
10184 if (POINTER_TYPE_P (stype
))
10185 stype
= TREE_TYPE (stype
);
10187 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10190 /* Determine the lengths of the arrays. */
10191 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10192 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10194 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10195 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10196 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10198 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10199 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10201 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10202 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10203 slen
, fold_convert (gfc_array_index_type
, tmp
));
10205 /* Sanity check that they are the same. This should always be
10206 the case, as we should already have checked for conformance. */
10207 if (!tree_int_cst_equal (slen
, dlen
))
10210 return gfc_build_memcpy_call (dst
, src
, dlen
);
10214 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10215 this can't be done. EXPR1 is the destination/lhs for which
10216 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10219 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10221 unsigned HOST_WIDE_INT nelem
;
10227 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
10231 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10232 dtype
= TREE_TYPE (dst
);
10233 if (POINTER_TYPE_P (dtype
))
10234 dtype
= TREE_TYPE (dtype
);
10235 if (!GFC_ARRAY_TYPE_P (dtype
))
10238 /* Determine the lengths of the array. */
10239 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
10240 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10243 /* Confirm that the constructor is the same size. */
10244 if (compare_tree_int (len
, nelem
) != 0)
10247 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10248 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10249 fold_convert (gfc_array_index_type
, tmp
));
10251 stype
= gfc_typenode_for_spec (&expr2
->ts
);
10252 src
= gfc_build_constant_array_constructor (expr2
, stype
);
10254 return gfc_build_memcpy_call (dst
, src
, len
);
10258 /* Tells whether the expression is to be treated as a variable reference. */
10261 gfc_expr_is_variable (gfc_expr
*expr
)
10264 gfc_component
*comp
;
10265 gfc_symbol
*func_ifc
;
10267 if (expr
->expr_type
== EXPR_VARIABLE
)
10270 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
10273 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
10274 return gfc_expr_is_variable (arg
);
10277 /* A data-pointer-returning function should be considered as a variable
10279 if (expr
->expr_type
== EXPR_FUNCTION
10280 && expr
->ref
== NULL
)
10282 if (expr
->value
.function
.isym
!= NULL
)
10285 if (expr
->value
.function
.esym
!= NULL
)
10287 func_ifc
= expr
->value
.function
.esym
;
10292 gcc_assert (expr
->symtree
);
10293 func_ifc
= expr
->symtree
->n
.sym
;
10297 gcc_unreachable ();
10300 comp
= gfc_get_proc_ptr_comp (expr
);
10301 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
10304 func_ifc
= comp
->ts
.interface
;
10308 if (expr
->expr_type
== EXPR_COMPCALL
)
10310 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
10311 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
10318 gcc_assert (func_ifc
->attr
.function
10319 && func_ifc
->result
!= NULL
);
10320 return func_ifc
->result
->attr
.pointer
;
10324 /* Is the lhs OK for automatic reallocation? */
10327 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
10331 /* An allocatable variable with no reference. */
10332 if (expr
->symtree
->n
.sym
->attr
.allocatable
10336 /* All that can be left are allocatable components. However, we do
10337 not check for allocatable components here because the expression
10338 could be an allocatable component of a pointer component. */
10339 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10340 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
10343 /* Find an allocatable component ref last. */
10344 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10345 if (ref
->type
== REF_COMPONENT
10347 && ref
->u
.c
.component
->attr
.allocatable
)
10354 /* Allocate or reallocate scalar lhs, as necessary. */
10357 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
10358 tree string_length
,
10366 tree size_in_bytes
;
10372 if (!expr1
|| expr1
->rank
)
10375 if (!expr2
|| expr2
->rank
)
10378 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10379 if (ref
->type
== REF_SUBSTRING
)
10382 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
10384 /* Since this is a scalar lhs, we can afford to do this. That is,
10385 there is no risk of side effects being repeated. */
10386 gfc_init_se (&lse
, NULL
);
10387 lse
.want_pointer
= 1;
10388 gfc_conv_expr (&lse
, expr1
);
10390 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10391 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10393 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10394 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
10395 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10397 tmp
= build3_v (COND_EXPR
, cond
,
10398 build1_v (GOTO_EXPR
, jump_label1
),
10399 build_empty_stmt (input_location
));
10400 gfc_add_expr_to_block (block
, tmp
);
10402 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10404 /* Use the rhs string length and the lhs element size. */
10405 size
= string_length
;
10406 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10407 tmp
= TYPE_SIZE_UNIT (tmp
);
10408 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10409 TREE_TYPE (tmp
), tmp
,
10410 fold_convert (TREE_TYPE (tmp
), size
));
10414 /* Otherwise use the length in bytes of the rhs. */
10415 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10416 size_in_bytes
= size
;
10419 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10420 size_in_bytes
, size_one_node
);
10422 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10424 tree caf_decl
, token
;
10426 symbol_attribute attr
;
10428 gfc_clear_attr (&attr
);
10429 gfc_init_se (&caf_se
, NULL
);
10431 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10432 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10434 gfc_add_block_to_block (block
, &caf_se
.pre
);
10435 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10436 gfc_build_addr_expr (NULL_TREE
, token
),
10437 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10440 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10442 tmp
= build_call_expr_loc (input_location
,
10443 builtin_decl_explicit (BUILT_IN_CALLOC
),
10444 2, build_one_cst (size_type_node
),
10446 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10447 gfc_add_modify (block
, lse
.expr
, tmp
);
10451 tmp
= build_call_expr_loc (input_location
,
10452 builtin_decl_explicit (BUILT_IN_MALLOC
),
10454 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10455 gfc_add_modify (block
, lse
.expr
, tmp
);
10458 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10460 /* Deferred characters need checking for lhs and rhs string
10461 length. Other deferred parameter variables will have to
10463 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10464 gfc_add_expr_to_block (block
, tmp
);
10466 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10467 gfc_add_expr_to_block (block
, tmp
);
10469 /* For a deferred length character, reallocate if lengths of lhs and
10470 rhs are different. */
10471 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10473 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10475 fold_convert (TREE_TYPE (lse
.string_length
),
10477 /* Jump past the realloc if the lengths are the same. */
10478 tmp
= build3_v (COND_EXPR
, cond
,
10479 build1_v (GOTO_EXPR
, jump_label2
),
10480 build_empty_stmt (input_location
));
10481 gfc_add_expr_to_block (block
, tmp
);
10482 tmp
= build_call_expr_loc (input_location
,
10483 builtin_decl_explicit (BUILT_IN_REALLOC
),
10484 2, fold_convert (pvoid_type_node
, lse
.expr
),
10486 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10487 gfc_add_modify (block
, lse
.expr
, tmp
);
10488 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10489 gfc_add_expr_to_block (block
, tmp
);
10491 /* Update the lhs character length. */
10492 size
= string_length
;
10493 gfc_add_modify (block
, lse
.string_length
,
10494 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10498 /* Check for assignments of the type
10502 to make sure we do not check for reallocation unneccessarily. */
10506 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10508 gfc_actual_arglist
*a
;
10511 switch (expr2
->expr_type
)
10513 case EXPR_VARIABLE
:
10514 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10516 case EXPR_FUNCTION
:
10517 if (expr2
->value
.function
.esym
10518 && expr2
->value
.function
.esym
->attr
.elemental
)
10520 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10523 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10528 else if (expr2
->value
.function
.isym
10529 && expr2
->value
.function
.isym
->elemental
)
10531 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10534 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10543 switch (expr2
->value
.op
.op
)
10545 case INTRINSIC_NOT
:
10546 case INTRINSIC_UPLUS
:
10547 case INTRINSIC_UMINUS
:
10548 case INTRINSIC_PARENTHESES
:
10549 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10551 case INTRINSIC_PLUS
:
10552 case INTRINSIC_MINUS
:
10553 case INTRINSIC_TIMES
:
10554 case INTRINSIC_DIVIDE
:
10555 case INTRINSIC_POWER
:
10556 case INTRINSIC_AND
:
10558 case INTRINSIC_EQV
:
10559 case INTRINSIC_NEQV
:
10566 case INTRINSIC_EQ_OS
:
10567 case INTRINSIC_NE_OS
:
10568 case INTRINSIC_GT_OS
:
10569 case INTRINSIC_GE_OS
:
10570 case INTRINSIC_LT_OS
:
10571 case INTRINSIC_LE_OS
:
10573 e1
= expr2
->value
.op
.op1
;
10574 e2
= expr2
->value
.op
.op2
;
10576 if (e1
->rank
== 0 && e2
->rank
> 0)
10577 return is_runtime_conformable (expr1
, e2
);
10578 else if (e1
->rank
> 0 && e2
->rank
== 0)
10579 return is_runtime_conformable (expr1
, e1
);
10580 else if (e1
->rank
> 0 && e2
->rank
> 0)
10581 return is_runtime_conformable (expr1
, e1
)
10582 && is_runtime_conformable (expr1
, e2
);
10600 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10601 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10602 bool class_realloc
)
10604 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
10605 vec
<tree
, va_gc
> *args
= NULL
;
10607 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10610 /* Generate allocation of the lhs. */
10616 tmp
= gfc_vptr_size_get (vptr
);
10617 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10618 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10619 gfc_init_block (&alloc
);
10620 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
10621 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10622 logical_type_node
, class_han
,
10623 build_int_cst (prvoid_type_node
, 0));
10624 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10626 PRED_FORTRAN_FAIL_ALLOC
),
10627 gfc_finish_block (&alloc
),
10628 build_empty_stmt (input_location
));
10629 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10632 fcn
= gfc_vptr_copy_get (vptr
);
10634 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10635 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10638 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10639 || INDIRECT_REF_P (tmp
)
10640 || (rhs
->ts
.type
== BT_DERIVED
10641 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10642 && !rhs
->ts
.u
.derived
->attr
.pointer
10643 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10644 || (UNLIMITED_POLY (rhs
)
10645 && !CLASS_DATA (rhs
)->attr
.pointer
10646 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10647 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10649 vec_safe_push (args
, tmp
);
10650 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10651 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10652 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10653 || INDIRECT_REF_P (tmp
)
10654 || (lhs
->ts
.type
== BT_DERIVED
10655 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10656 && !lhs
->ts
.u
.derived
->attr
.pointer
10657 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10658 || (UNLIMITED_POLY (lhs
)
10659 && !CLASS_DATA (lhs
)->attr
.pointer
10660 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10661 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10663 vec_safe_push (args
, tmp
);
10665 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10667 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10670 vec_safe_push (args
, from_len
);
10671 vec_safe_push (args
, to_len
);
10672 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10674 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10675 logical_type_node
, from_len
,
10676 build_zero_cst (TREE_TYPE (from_len
)));
10677 return fold_build3_loc (input_location
, COND_EXPR
,
10678 void_type_node
, tmp
,
10686 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10687 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10688 stmtblock_t tblock
;
10689 gfc_init_block (&tblock
);
10690 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10691 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10692 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10693 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10694 /* When coming from a ptr_copy lhs and rhs are swapped. */
10695 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10696 fold_convert (TREE_TYPE (rhst
), tmp
));
10697 return gfc_finish_block (&tblock
);
10701 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10702 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10703 init_flag indicates initialization expressions and dealloc that no
10704 deallocate prior assignment is needed (if in doubt, set true).
10705 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10706 routine instead of a pointer assignment. Alias resolution is only done,
10707 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10708 where it is known, that newly allocated memory on the lhs can never be
10709 an alias of the rhs. */
10712 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10713 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10718 gfc_ss
*lss_section
;
10725 bool scalar_to_array
;
10726 tree string_length
;
10728 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10729 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10730 bool is_poly_assign
;
10732 /* Assignment of the form lhs = rhs. */
10733 gfc_start_block (&block
);
10735 gfc_init_se (&lse
, NULL
);
10736 gfc_init_se (&rse
, NULL
);
10738 /* Walk the lhs. */
10739 lss
= gfc_walk_expr (expr1
);
10740 if (gfc_is_reallocatable_lhs (expr1
))
10742 lss
->no_bounds_check
= 1;
10743 if (!(expr2
->expr_type
== EXPR_FUNCTION
10744 && expr2
->value
.function
.isym
!= NULL
10745 && !(expr2
->value
.function
.isym
->elemental
10746 || expr2
->value
.function
.isym
->conversion
)))
10747 lss
->is_alloc_lhs
= 1;
10750 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10754 if ((expr1
->ts
.type
== BT_DERIVED
)
10755 && (gfc_is_class_array_function (expr2
)
10756 || gfc_is_alloc_class_scalar_function (expr2
)))
10757 expr2
->must_finalize
= 1;
10759 /* Checking whether a class assignment is desired is quite complicated and
10760 needed at two locations, so do it once only before the information is
10762 lhs_attr
= gfc_expr_attr (expr1
);
10763 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10764 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10765 && (expr1
->ts
.type
== BT_CLASS
10766 || gfc_is_class_array_ref (expr1
, NULL
)
10767 || gfc_is_class_scalar_expr (expr1
)
10768 || gfc_is_class_array_ref (expr2
, NULL
)
10769 || gfc_is_class_scalar_expr (expr2
));
10772 /* Only analyze the expressions for coarray properties, when in coarray-lib
10774 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10776 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10777 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10780 if (lss
!= gfc_ss_terminator
)
10782 /* The assignment needs scalarization. */
10785 /* Find a non-scalar SS from the lhs. */
10786 while (lss_section
!= gfc_ss_terminator
10787 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10788 lss_section
= lss_section
->next
;
10790 gcc_assert (lss_section
!= gfc_ss_terminator
);
10792 /* Initialize the scalarizer. */
10793 gfc_init_loopinfo (&loop
);
10795 /* Walk the rhs. */
10796 rss
= gfc_walk_expr (expr2
);
10797 if (rss
== gfc_ss_terminator
)
10798 /* The rhs is scalar. Add a ss for the expression. */
10799 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10800 /* When doing a class assign, then the handle to the rhs needs to be a
10801 pointer to allow for polymorphism. */
10802 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10803 rss
->info
->type
= GFC_SS_REFERENCE
;
10805 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10806 /* Associate the SS with the loop. */
10807 gfc_add_ss_to_loop (&loop
, lss
);
10808 gfc_add_ss_to_loop (&loop
, rss
);
10810 /* Calculate the bounds of the scalarization. */
10811 gfc_conv_ss_startstride (&loop
);
10812 /* Enable loop reversal. */
10813 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10814 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10815 /* Resolve any data dependencies in the statement. */
10817 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10818 /* Setup the scalarizing loops. */
10819 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10821 /* Setup the gfc_se structures. */
10822 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10823 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10826 gfc_mark_ss_chain_used (rss
, 1);
10827 if (loop
.temp_ss
== NULL
)
10830 gfc_mark_ss_chain_used (lss
, 1);
10834 lse
.ss
= loop
.temp_ss
;
10835 gfc_mark_ss_chain_used (lss
, 3);
10836 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10839 /* Allow the scalarizer to workshare array assignments. */
10840 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10841 == OMPWS_WORKSHARE_FLAG
10842 && loop
.temp_ss
== NULL
)
10844 maybe_workshare
= true;
10845 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10848 /* Start the scalarized loop body. */
10849 gfc_start_scalarized_body (&loop
, &body
);
10852 gfc_init_block (&body
);
10854 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10856 /* Translate the expression. */
10857 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10858 && lhs_caf_attr
.codimension
;
10859 gfc_conv_expr (&rse
, expr2
);
10861 /* Deal with the case of a scalar class function assigned to a derived type. */
10862 if (gfc_is_alloc_class_scalar_function (expr2
)
10863 && expr1
->ts
.type
== BT_DERIVED
)
10865 rse
.expr
= gfc_class_data_get (rse
.expr
);
10866 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10869 /* Stabilize a string length for temporaries. */
10870 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10871 && !(VAR_P (rse
.string_length
)
10872 || TREE_CODE (rse
.string_length
) == PARM_DECL
10873 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10874 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10875 else if (expr2
->ts
.type
== BT_CHARACTER
)
10877 if (expr1
->ts
.deferred
10878 && gfc_expr_attr (expr1
).allocatable
10879 && gfc_check_dependency (expr1
, expr2
, true))
10880 rse
.string_length
=
10881 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
10882 string_length
= rse
.string_length
;
10885 string_length
= NULL_TREE
;
10889 gfc_conv_tmp_array_ref (&lse
);
10890 if (expr2
->ts
.type
== BT_CHARACTER
)
10891 lse
.string_length
= string_length
;
10895 gfc_conv_expr (&lse
, expr1
);
10896 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10898 && gfc_expr_attr (expr1
).allocatable
10905 tmp
= INDIRECT_REF_P (lse
.expr
)
10906 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10908 /* We should only get array references here. */
10909 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10910 || TREE_CODE (tmp
) == ARRAY_REF
);
10912 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10913 or the array itself(ARRAY_REF). */
10914 tmp
= TREE_OPERAND (tmp
, 0);
10916 /* Provide the address of the array. */
10917 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10918 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10920 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10921 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10922 msg
= _("Assignment of scalar to unallocated array");
10923 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10924 &expr1
->where
, msg
);
10927 /* Deallocate the lhs parameterized components if required. */
10928 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10929 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10931 if (expr1
->ts
.type
== BT_DERIVED
10932 && expr1
->ts
.u
.derived
10933 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10935 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10937 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10939 else if (expr1
->ts
.type
== BT_CLASS
10940 && CLASS_DATA (expr1
)->ts
.u
.derived
10941 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10943 tmp
= gfc_class_data_get (lse
.expr
);
10944 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10946 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10951 /* Assignments of scalar derived types with allocatable components
10952 to arrays must be done with a deep copy and the rhs temporary
10953 must have its components deallocated afterwards. */
10954 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10955 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10956 && !gfc_expr_is_variable (expr2
)
10957 && expr1
->rank
&& !expr2
->rank
);
10958 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10960 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10961 && gfc_is_alloc_class_scalar_function (expr2
));
10962 if (scalar_to_array
&& dealloc
)
10964 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10965 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10968 /* When assigning a character function result to a deferred-length variable,
10969 the function call must happen before the (re)allocation of the lhs -
10970 otherwise the character length of the result is not known.
10971 NOTE 1: This relies on having the exact dependence of the length type
10972 parameter available to the caller; gfortran saves it in the .mod files.
10973 NOTE 2: Vector array references generate an index temporary that must
10974 not go outside the loop. Otherwise, variables should not generate
10976 NOTE 3: The concatenation operation generates a temporary pointer,
10977 whose allocation must go to the innermost loop.
10978 NOTE 4: Elemental functions may generate a temporary, too. */
10979 if (flag_realloc_lhs
10980 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10981 && !(lss
!= gfc_ss_terminator
10982 && rss
!= gfc_ss_terminator
10983 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
10984 || (expr2
->expr_type
== EXPR_FUNCTION
10985 && expr2
->value
.function
.esym
!= NULL
10986 && expr2
->value
.function
.esym
->attr
.elemental
)
10987 || (expr2
->expr_type
== EXPR_FUNCTION
10988 && expr2
->value
.function
.isym
!= NULL
10989 && expr2
->value
.function
.isym
->elemental
)
10990 || (expr2
->expr_type
== EXPR_OP
10991 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
10992 gfc_add_block_to_block (&block
, &rse
.pre
);
10994 /* Nullify the allocatable components corresponding to those of the lhs
10995 derived type, so that the finalization of the function result does not
10996 affect the lhs of the assignment. Prepend is used to ensure that the
10997 nullification occurs before the call to the finalizer. In the case of
10998 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10999 as part of the deep copy. */
11000 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11001 && (gfc_is_class_array_function (expr2
)
11002 || gfc_is_alloc_class_scalar_function (expr2
)))
11004 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11005 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11006 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11007 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11012 if (is_poly_assign
)
11013 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11014 use_vptr_copy
|| (lhs_attr
.allocatable
11015 && !lhs_attr
.dimension
),
11016 flag_realloc_lhs
&& !lhs_attr
.pointer
);
11017 else if (flag_coarray
== GFC_FCOARRAY_LIB
11018 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11019 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11020 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11022 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11023 allocatable component, because those need to be accessed via the
11024 caf-runtime. No need to check for coindexes here, because resolve
11025 has rewritten those already. */
11027 gfc_actual_arglist a1
, a2
;
11028 /* Clear the structures to prevent accessing garbage. */
11029 memset (&code
, '\0', sizeof (gfc_code
));
11030 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11031 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11036 code
.ext
.actual
= &a1
;
11037 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11038 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11040 else if (!is_poly_assign
&& expr2
->must_finalize
11041 && expr1
->ts
.type
== BT_CLASS
11042 && expr2
->ts
.type
== BT_CLASS
)
11044 /* This case comes about when the scalarizer provides array element
11045 references. Use the vptr copy function, since this does a deep
11046 copy of allocatable components, without which the finalizer call */
11047 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11048 if (tmp
!= NULL_TREE
)
11050 tree fcn
= gfc_vptr_copy_get (tmp
);
11051 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11052 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11053 tmp
= build_call_expr_loc (input_location
,
11055 gfc_build_addr_expr (NULL
, rse
.expr
),
11056 gfc_build_addr_expr (NULL
, lse
.expr
));
11060 /* If nothing else works, do it the old fashioned way! */
11061 if (tmp
== NULL_TREE
)
11062 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11063 gfc_expr_is_variable (expr2
)
11065 || expr2
->expr_type
== EXPR_ARRAY
,
11066 !(l_is_temp
|| init_flag
) && dealloc
,
11067 expr1
->symtree
->n
.sym
->attr
.codimension
);
11069 /* Add the pre blocks to the body. */
11070 gfc_add_block_to_block (&body
, &rse
.pre
);
11071 gfc_add_block_to_block (&body
, &lse
.pre
);
11072 gfc_add_expr_to_block (&body
, tmp
);
11073 /* Add the post blocks to the body. */
11074 gfc_add_block_to_block (&body
, &rse
.post
);
11075 gfc_add_block_to_block (&body
, &lse
.post
);
11077 if (lss
== gfc_ss_terminator
)
11079 /* F2003: Add the code for reallocation on assignment. */
11080 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11081 && !is_poly_assign
)
11082 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11085 /* Use the scalar assignment as is. */
11086 gfc_add_block_to_block (&block
, &body
);
11090 gcc_assert (lse
.ss
== gfc_ss_terminator
11091 && rse
.ss
== gfc_ss_terminator
);
11095 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11097 /* We need to copy the temporary to the actual lhs. */
11098 gfc_init_se (&lse
, NULL
);
11099 gfc_init_se (&rse
, NULL
);
11100 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11101 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11103 rse
.ss
= loop
.temp_ss
;
11106 gfc_conv_tmp_array_ref (&rse
);
11107 gfc_conv_expr (&lse
, expr1
);
11109 gcc_assert (lse
.ss
== gfc_ss_terminator
11110 && rse
.ss
== gfc_ss_terminator
);
11112 if (expr2
->ts
.type
== BT_CHARACTER
)
11113 rse
.string_length
= string_length
;
11115 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11117 gfc_add_expr_to_block (&body
, tmp
);
11120 /* F2003: Allocate or reallocate lhs of allocatable array. */
11121 if (flag_realloc_lhs
11122 && gfc_is_reallocatable_lhs (expr1
)
11124 && !is_runtime_conformable (expr1
, expr2
))
11126 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11127 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11128 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11129 if (tmp
!= NULL_TREE
)
11130 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11133 if (maybe_workshare
)
11134 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11136 /* Generate the copying loops. */
11137 gfc_trans_scalarizing_loops (&loop
, &body
);
11139 /* Wrap the whole thing up. */
11140 gfc_add_block_to_block (&block
, &loop
.pre
);
11141 gfc_add_block_to_block (&block
, &loop
.post
);
11143 gfc_cleanup_loop (&loop
);
11146 return gfc_finish_block (&block
);
11150 /* Check whether EXPR is a copyable array. */
11153 copyable_array_p (gfc_expr
* expr
)
11155 if (expr
->expr_type
!= EXPR_VARIABLE
)
11158 /* First check it's an array. */
11159 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11162 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11165 /* Next check that it's of a simple enough type. */
11166 switch (expr
->ts
.type
)
11178 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
11187 /* Translate an assignment. */
11190 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11191 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11195 /* Special case a single function returning an array. */
11196 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
11198 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
11203 /* Special case assigning an array to zero. */
11204 if (copyable_array_p (expr1
)
11205 && is_zero_initializer_p (expr2
))
11207 tmp
= gfc_trans_zero_assign (expr1
);
11212 /* Special case copying one array to another. */
11213 if (copyable_array_p (expr1
)
11214 && copyable_array_p (expr2
)
11215 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
11216 && !gfc_check_dependency (expr1
, expr2
, 0))
11218 tmp
= gfc_trans_array_copy (expr1
, expr2
);
11223 /* Special case initializing an array from a constant array constructor. */
11224 if (copyable_array_p (expr1
)
11225 && expr2
->expr_type
== EXPR_ARRAY
11226 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
11228 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
11233 if (UNLIMITED_POLY (expr1
) && expr1
->rank
11234 && expr2
->ts
.type
!= BT_CLASS
)
11235 use_vptr_copy
= true;
11237 /* Fallback to the scalarizer to generate explicit loops. */
11238 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
11239 use_vptr_copy
, may_alias
);
11243 gfc_trans_init_assign (gfc_code
* code
)
11245 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
11249 gfc_trans_assign (gfc_code
* code
)
11251 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);