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
)
848 /* The intrinsic type needs to be converted to a temporary
850 tmp
= gfc_typenode_for_spec (&class_ts
);
851 var
= gfc_create_var (tmp
, "class");
854 ctree
= gfc_class_vptr_get (var
);
856 vtab
= gfc_find_vtab (&e
->ts
);
858 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
859 gfc_add_modify (&parmse
->pre
, ctree
,
860 fold_convert (TREE_TYPE (ctree
), tmp
));
862 /* Now set the data field. */
863 ctree
= gfc_class_data_get (var
);
864 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
866 /* For an array reference in an elemental procedure call we need
867 to retain the ss to provide the scalarized array reference. */
868 gfc_conv_expr_reference (parmse
, e
);
869 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
870 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
874 ss
= gfc_walk_expr (e
);
875 if (ss
== gfc_ss_terminator
)
878 gfc_conv_expr_reference (parmse
, e
);
879 if (class_ts
.u
.derived
->components
->as
880 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
882 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
884 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
885 TREE_TYPE (ctree
), tmp
);
888 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
889 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
894 parmse
->use_offset
= 1;
895 gfc_conv_expr_descriptor (parmse
, e
);
897 /* Array references with vector subscripts and non-variable expressions
898 need be converted to a one-based descriptor. */
899 if (e
->expr_type
!= EXPR_VARIABLE
)
901 for (dim
= 0; dim
< e
->rank
; ++dim
)
902 gfc_conv_shift_descriptor_lbound (&parmse
->pre
, parmse
->expr
,
903 dim
, gfc_index_one_node
);
906 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
908 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
909 TREE_TYPE (ctree
), parmse
->expr
);
910 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
913 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
917 gcc_assert (class_ts
.type
== BT_CLASS
);
918 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
919 && class_ts
.u
.derived
->components
->ts
.u
.derived
920 ->attr
.unlimited_polymorphic
)
922 ctree
= gfc_class_len_get (var
);
923 /* When the actual arg is a char array, then set the _len component of the
924 unlimited polymorphic entity to the length of the string. */
925 if (e
->ts
.type
== BT_CHARACTER
)
927 /* Start with parmse->string_length because this seems to be set to a
928 correct value more often. */
929 if (parmse
->string_length
)
930 tmp
= parmse
->string_length
;
931 /* When the string_length is not yet set, then try the backend_decl of
933 else if (e
->ts
.u
.cl
->backend_decl
)
934 tmp
= e
->ts
.u
.cl
->backend_decl
;
935 /* If both of the above approaches fail, then try to generate an
936 expression from the input, which is only feasible currently, when the
937 expression can be evaluated to a constant one. */
940 /* Try to simplify the expression. */
941 gfc_simplify_expr (e
, 0);
942 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
944 /* Amazingly all data is present to compute the length of a
945 constant string, but the expression is not yet there. */
946 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
947 gfc_charlen_int_kind
,
949 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
950 e
->value
.character
.length
);
951 gfc_conv_const_charlen (e
->ts
.u
.cl
);
952 e
->ts
.u
.cl
->resolved
= 1;
953 tmp
= e
->ts
.u
.cl
->backend_decl
;
957 gfc_error ("Cannot compute the length of the char array "
958 "at %L.", &e
->where
);
963 tmp
= integer_zero_node
;
965 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
967 else if (class_ts
.type
== BT_CLASS
968 && class_ts
.u
.derived
->components
969 && class_ts
.u
.derived
->components
->ts
.u
970 .derived
->attr
.unlimited_polymorphic
)
972 ctree
= gfc_class_len_get (var
);
973 gfc_add_modify (&parmse
->pre
, ctree
,
974 fold_convert (TREE_TYPE (ctree
),
977 /* Pass the address of the class object. */
978 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
982 /* Takes a scalarized class array expression and returns the
983 address of a temporary scalar class object of the 'declared'
985 OOP-TODO: This could be improved by adding code that branched on
986 the dynamic type being the same as the declared type. In this case
987 the original class expression can be passed directly.
988 optional_alloc_ptr is false when the dummy is neither allocatable
989 nor a pointer; that's relevant for the optional handling.
990 Set copyback to true if class container's _data and _vtab pointers
991 might get modified. */
994 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
995 bool elemental
, bool copyback
, bool optional
,
996 bool optional_alloc_ptr
)
1002 tree cond
= NULL_TREE
;
1003 tree slen
= NULL_TREE
;
1007 bool full_array
= false;
1009 gfc_init_block (&block
);
1012 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1014 if (ref
->type
== REF_COMPONENT
1015 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1018 if (ref
->next
== NULL
)
1022 if ((ref
== NULL
|| class_ref
== ref
)
1023 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1024 && (!class_ts
.u
.derived
->components
->as
1025 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1028 /* Test for FULL_ARRAY. */
1029 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1030 && gfc_expr_attr (e
).dimension
)
1033 gfc_is_class_array_ref (e
, &full_array
);
1035 /* The derived type needs to be converted to a temporary
1037 tmp
= gfc_typenode_for_spec (&class_ts
);
1038 var
= gfc_create_var (tmp
, "class");
1041 ctree
= gfc_class_data_get (var
);
1042 if (class_ts
.u
.derived
->components
->as
1043 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1047 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1049 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1050 gfc_get_dtype (type
));
1052 tmp
= gfc_class_data_get (parmse
->expr
);
1053 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1054 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1056 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1059 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1063 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1064 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1065 TREE_TYPE (ctree
), parmse
->expr
);
1066 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1069 /* Return the data component, except in the case of scalarized array
1070 references, where nullification of the cannot occur and so there
1072 if (!elemental
&& full_array
&& copyback
)
1074 if (class_ts
.u
.derived
->components
->as
1075 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1078 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1079 gfc_conv_descriptor_data_get (ctree
));
1081 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1084 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1088 ctree
= gfc_class_vptr_get (var
);
1090 /* The vptr is the second field of the actual argument.
1091 First we have to find the corresponding class reference. */
1094 if (gfc_is_class_array_function (e
)
1095 && parmse
->class_vptr
!= NULL_TREE
)
1096 tmp
= parmse
->class_vptr
;
1097 else if (class_ref
== NULL
1098 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1100 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1102 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1103 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1105 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1106 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1108 slen
= build_zero_cst (size_type_node
);
1112 /* Remove everything after the last class reference, convert the
1113 expression and then recover its tailend once more. */
1115 ref
= class_ref
->next
;
1116 class_ref
->next
= NULL
;
1117 gfc_init_se (&tmpse
, NULL
);
1118 gfc_conv_expr (&tmpse
, e
);
1119 class_ref
->next
= ref
;
1121 slen
= tmpse
.string_length
;
1124 gcc_assert (tmp
!= NULL_TREE
);
1126 /* Dereference if needs be. */
1127 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1128 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1130 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1131 vptr
= gfc_class_vptr_get (tmp
);
1135 gfc_add_modify (&block
, ctree
,
1136 fold_convert (TREE_TYPE (ctree
), vptr
));
1138 /* Return the vptr component, except in the case of scalarized array
1139 references, where the dynamic type cannot change. */
1140 if (!elemental
&& full_array
&& copyback
)
1141 gfc_add_modify (&parmse
->post
, vptr
,
1142 fold_convert (TREE_TYPE (vptr
), ctree
));
1144 /* For unlimited polymorphic objects also set the _len component. */
1145 if (class_ts
.type
== BT_CLASS
1146 && class_ts
.u
.derived
->components
1147 && class_ts
.u
.derived
->components
->ts
.u
1148 .derived
->attr
.unlimited_polymorphic
)
1150 ctree
= gfc_class_len_get (var
);
1151 if (UNLIMITED_POLY (e
))
1152 tmp
= gfc_class_len_get (tmp
);
1153 else if (e
->ts
.type
== BT_CHARACTER
)
1155 gcc_assert (slen
!= NULL_TREE
);
1159 tmp
= build_zero_cst (size_type_node
);
1160 gfc_add_modify (&parmse
->pre
, ctree
,
1161 fold_convert (TREE_TYPE (ctree
), tmp
));
1163 /* Return the len component, except in the case of scalarized array
1164 references, where the dynamic type cannot change. */
1165 if (!elemental
&& full_array
&& copyback
1166 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1167 gfc_add_modify (&parmse
->post
, tmp
,
1168 fold_convert (TREE_TYPE (tmp
), ctree
));
1175 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1176 /* parmse->pre may contain some preparatory instructions for the
1177 temporary array descriptor. Those may only be executed when the
1178 optional argument is set, therefore add parmse->pre's instructions
1179 to block, which is later guarded by an if (optional_arg_given). */
1180 gfc_add_block_to_block (&parmse
->pre
, &block
);
1181 block
.head
= parmse
->pre
.head
;
1182 parmse
->pre
.head
= NULL_TREE
;
1183 tmp
= gfc_finish_block (&block
);
1185 if (optional_alloc_ptr
)
1186 tmp2
= build_empty_stmt (input_location
);
1189 gfc_init_block (&block
);
1191 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1192 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1193 null_pointer_node
));
1194 tmp2
= gfc_finish_block (&block
);
1197 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1199 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1202 gfc_add_block_to_block (&parmse
->pre
, &block
);
1204 /* Pass the address of the class object. */
1205 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1207 if (optional
&& optional_alloc_ptr
)
1208 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1209 TREE_TYPE (parmse
->expr
),
1211 fold_convert (TREE_TYPE (parmse
->expr
),
1212 null_pointer_node
));
1216 /* Given a class array declaration and an index, returns the address
1217 of the referenced element. */
1220 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1223 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1225 data
= data_comp
!= NULL_TREE
? data_comp
:
1226 gfc_class_data_get (class_decl
);
1227 size
= gfc_class_vtab_size_get (class_decl
);
1231 tmp
= fold_convert (gfc_array_index_type
,
1232 gfc_class_len_get (class_decl
));
1233 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1234 gfc_array_index_type
, size
, tmp
);
1235 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1236 logical_type_node
, tmp
,
1237 build_zero_cst (TREE_TYPE (tmp
)));
1238 size
= fold_build3_loc (input_location
, COND_EXPR
,
1239 gfc_array_index_type
, tmp
, ctmp
, size
);
1242 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1243 gfc_array_index_type
,
1246 data
= gfc_conv_descriptor_data_get (data
);
1247 ptr
= fold_convert (pvoid_type_node
, data
);
1248 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1249 return fold_convert (TREE_TYPE (data
), ptr
);
1253 /* Copies one class expression to another, assuming that if either
1254 'to' or 'from' are arrays they are packed. Should 'from' be
1255 NULL_TREE, the initialization expression for 'to' is used, assuming
1256 that the _vptr is set. */
1259 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1269 vec
<tree
, va_gc
> *args
;
1274 bool is_from_desc
= false, is_to_class
= false;
1277 /* To prevent warnings on uninitialized variables. */
1278 from_len
= to_len
= NULL_TREE
;
1280 if (from
!= NULL_TREE
)
1281 fcn
= gfc_class_vtab_copy_get (from
);
1283 fcn
= gfc_class_vtab_copy_get (to
);
1285 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1287 if (from
!= NULL_TREE
)
1289 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1293 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1297 /* Check that from is a class. When the class is part of a coarray,
1298 then from is a common pointer and is to be used as is. */
1299 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1300 ? build_fold_indirect_ref (from
) : from
;
1302 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1303 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1304 ? gfc_class_data_get (from
) : from
;
1305 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1309 from_data
= gfc_class_vtab_def_init_get (to
);
1313 if (from
!= NULL_TREE
&& unlimited
)
1314 from_len
= gfc_class_len_or_zero_get (from
);
1316 from_len
= build_zero_cst (size_type_node
);
1319 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1322 to_data
= gfc_class_data_get (to
);
1324 to_len
= gfc_class_len_get (to
);
1327 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1330 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1332 stmtblock_t loopbody
;
1336 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1338 gfc_init_block (&body
);
1339 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1340 gfc_array_index_type
, nelems
,
1341 gfc_index_one_node
);
1342 nelems
= gfc_evaluate_now (tmp
, &body
);
1343 index
= gfc_create_var (gfc_array_index_type
, "S");
1347 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1349 vec_safe_push (args
, from_ref
);
1352 vec_safe_push (args
, from_data
);
1355 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1358 tmp
= gfc_conv_array_data (to
);
1359 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1360 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1361 gfc_build_array_ref (tmp
, index
, to
));
1363 vec_safe_push (args
, to_ref
);
1365 /* Add bounds check. */
1366 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1369 const char *name
= "<<unknown>>";
1373 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1375 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1376 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1377 logical_type_node
, from_len
, orig_nelems
);
1378 msg
= xasprintf ("Array bound mismatch for dimension %d "
1379 "of array '%s' (%%ld/%%ld)",
1382 gfc_trans_runtime_check (true, false, tmp
, &body
,
1383 &gfc_current_locus
, msg
,
1384 fold_convert (long_integer_type_node
, orig_nelems
),
1385 fold_convert (long_integer_type_node
, from_len
));
1390 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1392 /* Build the body of the loop. */
1393 gfc_init_block (&loopbody
);
1394 gfc_add_expr_to_block (&loopbody
, tmp
);
1396 /* Build the loop and return. */
1397 gfc_init_loopinfo (&loop
);
1399 loop
.from
[0] = gfc_index_zero_node
;
1400 loop
.loopvar
[0] = index
;
1401 loop
.to
[0] = nelems
;
1402 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1403 gfc_init_block (&ifbody
);
1404 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1405 stdcopy
= gfc_finish_block (&ifbody
);
1406 /* In initialization mode from_len is a constant zero. */
1407 if (unlimited
&& !integer_zerop (from_len
))
1409 vec_safe_push (args
, from_len
);
1410 vec_safe_push (args
, to_len
);
1411 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1412 /* Build the body of the loop. */
1413 gfc_init_block (&loopbody
);
1414 gfc_add_expr_to_block (&loopbody
, tmp
);
1416 /* Build the loop and return. */
1417 gfc_init_loopinfo (&loop
);
1419 loop
.from
[0] = gfc_index_zero_node
;
1420 loop
.loopvar
[0] = index
;
1421 loop
.to
[0] = nelems
;
1422 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1423 gfc_init_block (&ifbody
);
1424 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1425 extcopy
= gfc_finish_block (&ifbody
);
1427 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1428 logical_type_node
, from_len
,
1429 build_zero_cst (TREE_TYPE (from_len
)));
1430 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1431 void_type_node
, tmp
, extcopy
, stdcopy
);
1432 gfc_add_expr_to_block (&body
, tmp
);
1433 tmp
= gfc_finish_block (&body
);
1437 gfc_add_expr_to_block (&body
, stdcopy
);
1438 tmp
= gfc_finish_block (&body
);
1440 gfc_cleanup_loop (&loop
);
1444 gcc_assert (!is_from_desc
);
1445 vec_safe_push (args
, from_data
);
1446 vec_safe_push (args
, to_data
);
1447 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1449 /* In initialization mode from_len is a constant zero. */
1450 if (unlimited
&& !integer_zerop (from_len
))
1452 vec_safe_push (args
, from_len
);
1453 vec_safe_push (args
, to_len
);
1454 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1455 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1456 logical_type_node
, from_len
,
1457 build_zero_cst (TREE_TYPE (from_len
)));
1458 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1459 void_type_node
, tmp
, extcopy
, stdcopy
);
1465 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1466 if (from
== NULL_TREE
)
1469 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1471 from_data
, null_pointer_node
);
1472 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1473 void_type_node
, cond
,
1474 tmp
, build_empty_stmt (input_location
));
1482 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1484 gfc_actual_arglist
*actual
;
1489 actual
= gfc_get_actual_arglist ();
1490 actual
->expr
= gfc_copy_expr (rhs
);
1491 actual
->next
= gfc_get_actual_arglist ();
1492 actual
->next
->expr
= gfc_copy_expr (lhs
);
1493 ppc
= gfc_copy_expr (obj
);
1494 gfc_add_vptr_component (ppc
);
1495 gfc_add_component_ref (ppc
, "_copy");
1496 ppc_code
= gfc_get_code (EXEC_CALL
);
1497 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1498 /* Although '_copy' is set to be elemental in class.c, it is
1499 not staying that way. Find out why, sometime.... */
1500 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1501 ppc_code
->ext
.actual
= actual
;
1502 ppc_code
->expr1
= ppc
;
1503 /* Since '_copy' is elemental, the scalarizer will take care
1504 of arrays in gfc_trans_call. */
1505 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1506 gfc_free_statements (ppc_code
);
1508 if (UNLIMITED_POLY(obj
))
1510 /* Check if rhs is non-NULL. */
1512 gfc_init_se (&src
, NULL
);
1513 gfc_conv_expr (&src
, rhs
);
1514 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1515 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1516 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1517 null_pointer_node
));
1518 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1519 build_empty_stmt (input_location
));
1525 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1526 A MEMCPY is needed to copy the full data from the default initializer
1527 of the dynamic type. */
1530 gfc_trans_class_init_assign (gfc_code
*code
)
1534 gfc_se dst
,src
,memsz
;
1535 gfc_expr
*lhs
, *rhs
, *sz
;
1537 gfc_start_block (&block
);
1539 lhs
= gfc_copy_expr (code
->expr1
);
1541 rhs
= gfc_copy_expr (code
->expr1
);
1542 gfc_add_vptr_component (rhs
);
1544 /* Make sure that the component backend_decls have been built, which
1545 will not have happened if the derived types concerned have not
1547 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1548 gfc_add_def_init_component (rhs
);
1549 /* The _def_init is always scalar. */
1552 if (code
->expr1
->ts
.type
== BT_CLASS
1553 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1555 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1556 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1557 /* Adding the array ref to the class expression results in correct
1558 indexing to the dynamic type. */
1559 gfc_add_full_array_ref (lhs
, tmparr
);
1560 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1564 /* Scalar initialization needs the _data component. */
1565 gfc_add_data_component (lhs
);
1566 sz
= gfc_copy_expr (code
->expr1
);
1567 gfc_add_vptr_component (sz
);
1568 gfc_add_size_component (sz
);
1570 gfc_init_se (&dst
, NULL
);
1571 gfc_init_se (&src
, NULL
);
1572 gfc_init_se (&memsz
, NULL
);
1573 gfc_conv_expr (&dst
, lhs
);
1574 gfc_conv_expr (&src
, rhs
);
1575 gfc_conv_expr (&memsz
, sz
);
1576 gfc_add_block_to_block (&block
, &src
.pre
);
1577 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1579 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1581 if (UNLIMITED_POLY(code
->expr1
))
1583 /* Check if _def_init is non-NULL. */
1584 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1585 logical_type_node
, src
.expr
,
1586 fold_convert (TREE_TYPE (src
.expr
),
1587 null_pointer_node
));
1588 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1589 tmp
, build_empty_stmt (input_location
));
1593 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1594 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1596 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1597 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1599 build_empty_stmt (input_location
));
1602 gfc_add_expr_to_block (&block
, tmp
);
1604 return gfc_finish_block (&block
);
1608 /* End of prototype trans-class.c */
1612 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1614 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1615 gfc_warning (OPT_Wrealloc_lhs
,
1616 "Code for reallocating the allocatable array at %L will "
1618 else if (warn_realloc_lhs_all
)
1619 gfc_warning (OPT_Wrealloc_lhs_all
,
1620 "Code for reallocating the allocatable variable at %L "
1621 "will be added", where
);
1625 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1628 /* Copy the scalarization loop variables. */
1631 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1634 dest
->loop
= src
->loop
;
1638 /* Initialize a simple expression holder.
1640 Care must be taken when multiple se are created with the same parent.
1641 The child se must be kept in sync. The easiest way is to delay creation
1642 of a child se until after the previous se has been translated. */
1645 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1647 memset (se
, 0, sizeof (gfc_se
));
1648 gfc_init_block (&se
->pre
);
1649 gfc_init_block (&se
->post
);
1651 se
->parent
= parent
;
1654 gfc_copy_se_loopvars (se
, parent
);
1658 /* Advances to the next SS in the chain. Use this rather than setting
1659 se->ss = se->ss->next because all the parents needs to be kept in sync.
1663 gfc_advance_se_ss_chain (gfc_se
* se
)
1668 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1671 /* Walk down the parent chain. */
1674 /* Simple consistency check. */
1675 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1676 || p
->parent
->ss
->nested_ss
== p
->ss
);
1678 /* If we were in a nested loop, the next scalarized expression can be
1679 on the parent ss' next pointer. Thus we should not take the next
1680 pointer blindly, but rather go up one nest level as long as next
1681 is the end of chain. */
1683 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1693 /* Ensures the result of the expression as either a temporary variable
1694 or a constant so that it can be used repeatedly. */
1697 gfc_make_safe_expr (gfc_se
* se
)
1701 if (CONSTANT_CLASS_P (se
->expr
))
1704 /* We need a temporary for this result. */
1705 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1706 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1711 /* Return an expression which determines if a dummy parameter is present.
1712 Also used for arguments to procedures with multiple entry points. */
1715 gfc_conv_expr_present (gfc_symbol
* sym
)
1719 gcc_assert (sym
->attr
.dummy
);
1720 decl
= gfc_get_symbol_decl (sym
);
1722 /* Intrinsic scalars with VALUE attribute which are passed by value
1723 use a hidden argument to denote the present status. */
1724 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1725 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1726 && !sym
->attr
.dimension
)
1728 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1731 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1733 strcpy (&name
[1], sym
->name
);
1734 tree_name
= get_identifier (name
);
1736 /* Walk function argument list to find hidden arg. */
1737 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1738 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1739 if (DECL_NAME (cond
) == tree_name
1740 && DECL_ARTIFICIAL (cond
))
1747 if (TREE_CODE (decl
) != PARM_DECL
)
1749 /* Array parameters use a temporary descriptor, we want the real
1751 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1752 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1753 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1756 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1757 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1759 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1760 as actual argument to denote absent dummies. For array descriptors,
1761 we thus also need to check the array descriptor. For BT_CLASS, it
1762 can also occur for scalars and F2003 due to type->class wrapping and
1763 class->class wrapping. Note further that BT_CLASS always uses an
1764 array descriptor for arrays, also for explicit-shape/assumed-size. */
1766 if (!sym
->attr
.allocatable
1767 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1768 || (sym
->ts
.type
== BT_CLASS
1769 && !CLASS_DATA (sym
)->attr
.allocatable
1770 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1771 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1772 || sym
->ts
.type
== BT_CLASS
))
1776 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1777 || sym
->as
->type
== AS_ASSUMED_RANK
1778 || sym
->attr
.codimension
))
1779 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1781 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1782 if (sym
->ts
.type
== BT_CLASS
)
1783 tmp
= gfc_class_data_get (tmp
);
1784 tmp
= gfc_conv_array_data (tmp
);
1786 else if (sym
->ts
.type
== BT_CLASS
)
1787 tmp
= gfc_class_data_get (decl
);
1791 if (tmp
!= NULL_TREE
)
1793 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1794 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1795 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1796 logical_type_node
, cond
, tmp
);
1804 /* Converts a missing, dummy argument into a null or zero. */
1807 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1812 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1816 /* Create a temporary and convert it to the correct type. */
1817 tmp
= gfc_get_int_type (kind
);
1818 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1821 /* Test for a NULL value. */
1822 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1823 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1824 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1825 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1829 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1831 build_zero_cst (TREE_TYPE (se
->expr
)));
1832 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1836 if (ts
.type
== BT_CHARACTER
)
1838 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1839 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1840 present
, se
->string_length
, tmp
);
1841 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1842 se
->string_length
= tmp
;
1848 /* Get the character length of an expression, looking through gfc_refs
1852 gfc_get_expr_charlen (gfc_expr
*e
)
1858 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1859 && e
->ts
.type
== BT_CHARACTER
);
1861 length
= NULL
; /* To silence compiler warning. */
1863 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1866 gfc_init_se (&tmpse
, NULL
);
1867 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1868 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1872 /* First candidate: if the variable is of type CHARACTER, the
1873 expression's length could be the length of the character
1875 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1876 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1878 /* Look through the reference chain for component references. */
1879 for (r
= e
->ref
; r
; r
= r
->next
)
1884 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1885 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1893 gfc_init_se (&se
, NULL
);
1894 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
1896 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
1897 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
1898 gfc_charlen_type_node
,
1900 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
1901 gfc_charlen_type_node
, length
,
1902 gfc_index_one_node
);
1911 gcc_assert (length
!= NULL
);
1916 /* Return for an expression the backend decl of the coarray. */
1919 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1925 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1927 /* Not-implemented diagnostic. */
1928 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1929 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1930 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1931 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1932 "%L is not supported", &expr
->where
);
1934 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1935 if (ref
->type
== REF_COMPONENT
)
1937 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1938 && UNLIMITED_POLY (ref
->u
.c
.component
)
1939 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1940 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1941 "component at %L is not supported", &expr
->where
);
1944 /* Make sure the backend_decl is present before accessing it. */
1945 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1946 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1947 : expr
->symtree
->n
.sym
->backend_decl
;
1949 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1951 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1953 caf_decl
= gfc_class_data_get (caf_decl
);
1954 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1957 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1959 if (ref
->type
== REF_COMPONENT
1960 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1962 caf_decl
= gfc_class_data_get (caf_decl
);
1963 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1967 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1971 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1974 /* The following code assumes that the coarray is a component reachable via
1975 only scalar components/variables; the Fortran standard guarantees this. */
1977 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1978 if (ref
->type
== REF_COMPONENT
)
1980 gfc_component
*comp
= ref
->u
.c
.component
;
1982 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1983 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1984 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1985 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1986 comp
->backend_decl
, NULL_TREE
);
1987 if (comp
->ts
.type
== BT_CLASS
)
1989 caf_decl
= gfc_class_data_get (caf_decl
);
1990 if (CLASS_DATA (comp
)->attr
.codimension
)
1996 if (comp
->attr
.codimension
)
2002 gcc_assert (found
&& caf_decl
);
2007 /* Obtain the Coarray token - and optionally also the offset. */
2010 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2011 tree se_expr
, gfc_expr
*expr
)
2015 /* Coarray token. */
2016 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2018 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2019 == GFC_ARRAY_ALLOCATABLE
2020 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2021 *token
= gfc_conv_descriptor_token (caf_decl
);
2023 else if (DECL_LANG_SPECIFIC (caf_decl
)
2024 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2025 *token
= GFC_DECL_TOKEN (caf_decl
);
2028 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2029 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2030 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2036 /* Offset between the coarray base address and the address wanted. */
2037 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2038 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2039 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2040 *offset
= build_int_cst (gfc_array_index_type
, 0);
2041 else if (DECL_LANG_SPECIFIC (caf_decl
)
2042 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2043 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2044 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2045 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2047 *offset
= build_int_cst (gfc_array_index_type
, 0);
2049 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2050 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2052 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2053 tmp
= gfc_conv_descriptor_data_get (tmp
);
2055 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2056 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2059 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2063 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2064 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2066 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2067 && expr
->symtree
->n
.sym
->attr
.codimension
2068 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2070 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2071 gfc_ref
*ref
= base_expr
->ref
;
2074 // Iterate through the refs until the last one.
2078 if (ref
->type
== REF_ARRAY
2079 && ref
->u
.ar
.type
!= AR_FULL
)
2081 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2083 for (i
= 0; i
< ranksum
; ++i
)
2085 ref
->u
.ar
.start
[i
] = NULL
;
2086 ref
->u
.ar
.end
[i
] = NULL
;
2088 ref
->u
.ar
.type
= AR_FULL
;
2090 gfc_init_se (&base_se
, NULL
);
2091 if (gfc_caf_attr (base_expr
).dimension
)
2093 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2094 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2098 gfc_conv_expr (&base_se
, base_expr
);
2102 gfc_free_expr (base_expr
);
2103 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2104 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2106 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2107 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2110 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2114 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2115 fold_convert (gfc_array_index_type
, *offset
),
2116 fold_convert (gfc_array_index_type
, tmp
));
2120 /* Convert the coindex of a coarray into an image index; the result is
2121 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2122 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2125 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2128 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2132 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2133 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2135 gcc_assert (ref
!= NULL
);
2137 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2139 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2143 img_idx
= build_zero_cst (gfc_array_index_type
);
2144 extent
= build_one_cst (gfc_array_index_type
);
2145 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2146 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2148 gfc_init_se (&se
, NULL
);
2149 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2150 gfc_add_block_to_block (block
, &se
.pre
);
2151 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2152 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2153 TREE_TYPE (lbound
), se
.expr
, lbound
);
2154 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2156 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2157 TREE_TYPE (tmp
), img_idx
, tmp
);
2158 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2160 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2161 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2162 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2163 TREE_TYPE (tmp
), extent
, tmp
);
2167 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2169 gfc_init_se (&se
, NULL
);
2170 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2171 gfc_add_block_to_block (block
, &se
.pre
);
2172 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2173 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2174 TREE_TYPE (lbound
), se
.expr
, lbound
);
2175 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2177 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2179 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2181 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2182 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2183 TREE_TYPE (ubound
), ubound
, lbound
);
2184 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2185 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2186 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2187 TREE_TYPE (tmp
), extent
, tmp
);
2190 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2191 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2192 return fold_convert (integer_type_node
, img_idx
);
2196 /* For each character array constructor subexpression without a ts.u.cl->length,
2197 replace it by its first element (if there aren't any elements, the length
2198 should already be set to zero). */
2201 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2203 gfc_actual_arglist
* arg
;
2209 switch (e
->expr_type
)
2213 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2214 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2218 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2222 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2223 flatten_array_ctors_without_strlen (arg
->expr
);
2228 /* We've found what we're looking for. */
2229 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2234 gcc_assert (e
->value
.constructor
);
2236 c
= gfc_constructor_first (e
->value
.constructor
);
2240 flatten_array_ctors_without_strlen (new_expr
);
2241 gfc_replace_expr (e
, new_expr
);
2245 /* Otherwise, fall through to handle constructor elements. */
2247 case EXPR_STRUCTURE
:
2248 for (c
= gfc_constructor_first (e
->value
.constructor
);
2249 c
; c
= gfc_constructor_next (c
))
2250 flatten_array_ctors_without_strlen (c
->expr
);
2260 /* Generate code to initialize a string length variable. Returns the
2261 value. For array constructors, cl->length might be NULL and in this case,
2262 the first element of the constructor is needed. expr is the original
2263 expression so we can access it but can be NULL if this is not needed. */
2266 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2270 gfc_init_se (&se
, NULL
);
2272 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2275 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2276 "flatten" array constructors by taking their first element; all elements
2277 should be the same length or a cl->length should be present. */
2280 gfc_expr
* expr_flat
;
2283 expr_flat
= gfc_copy_expr (expr
);
2284 flatten_array_ctors_without_strlen (expr_flat
);
2285 gfc_resolve_expr (expr_flat
);
2287 gfc_conv_expr (&se
, expr_flat
);
2288 gfc_add_block_to_block (pblock
, &se
.pre
);
2289 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2291 gfc_free_expr (expr_flat
);
2295 /* Convert cl->length. */
2297 gcc_assert (cl
->length
);
2299 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2300 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2301 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2302 gfc_add_block_to_block (pblock
, &se
.pre
);
2304 if (cl
->backend_decl
)
2305 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2307 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2312 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2313 const char *name
, locus
*where
)
2323 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2324 type
= build_pointer_type (type
);
2326 gfc_init_se (&start
, se
);
2327 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2328 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2330 if (integer_onep (start
.expr
))
2331 gfc_conv_string_parameter (se
);
2336 /* Avoid multiple evaluation of substring start. */
2337 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2338 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2340 /* Change the start of the string. */
2341 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2342 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2343 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2346 tmp
= build_fold_indirect_ref_loc (input_location
,
2348 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2349 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
2351 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2352 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2356 /* Length = end + 1 - start. */
2357 gfc_init_se (&end
, se
);
2358 if (ref
->u
.ss
.end
== NULL
)
2359 end
.expr
= se
->string_length
;
2362 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2363 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2367 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2368 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2370 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2372 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2373 logical_type_node
, start
.expr
,
2376 /* Check lower bound. */
2377 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2379 build_one_cst (TREE_TYPE (start
.expr
)));
2380 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2381 logical_type_node
, nonempty
, fault
);
2383 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2384 "is less than one", name
);
2386 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2387 "is less than one");
2388 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2389 fold_convert (long_integer_type_node
,
2393 /* Check upper bound. */
2394 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2395 end
.expr
, se
->string_length
);
2396 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2397 logical_type_node
, nonempty
, fault
);
2399 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2400 "exceeds string length (%%ld)", name
);
2402 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2403 "exceeds string length (%%ld)");
2404 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2405 fold_convert (long_integer_type_node
, end
.expr
),
2406 fold_convert (long_integer_type_node
,
2407 se
->string_length
));
2411 /* Try to calculate the length from the start and end expressions. */
2413 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2415 HOST_WIDE_INT i_len
;
2417 i_len
= gfc_mpz_get_hwi (length
) + 1;
2421 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2422 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2426 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2427 fold_convert (gfc_charlen_type_node
, end
.expr
),
2428 fold_convert (gfc_charlen_type_node
, start
.expr
));
2429 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2430 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2431 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2432 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2435 se
->string_length
= tmp
;
2439 /* Convert a derived type component reference. */
2442 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2450 c
= ref
->u
.c
.component
;
2452 if (c
->backend_decl
== NULL_TREE
2453 && ref
->u
.c
.sym
!= NULL
)
2454 gfc_get_derived_type (ref
->u
.c
.sym
);
2456 field
= c
->backend_decl
;
2457 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2459 context
= DECL_FIELD_CONTEXT (field
);
2461 /* Components can correspond to fields of different containing
2462 types, as components are created without context, whereas
2463 a concrete use of a component has the type of decl as context.
2464 So, if the type doesn't match, we search the corresponding
2465 FIELD_DECL in the parent type. To not waste too much time
2466 we cache this result in norestrict_decl.
2467 On the other hand, if the context is a UNION or a MAP (a
2468 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2470 if (context
!= TREE_TYPE (decl
)
2471 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2472 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2474 tree f2
= c
->norestrict_decl
;
2475 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2476 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2477 if (TREE_CODE (f2
) == FIELD_DECL
2478 && DECL_NAME (f2
) == DECL_NAME (field
))
2481 c
->norestrict_decl
= f2
;
2485 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2486 && strcmp ("_data", c
->name
) == 0)
2488 /* Found a ref to the _data component. Store the associated ref to
2489 the vptr in se->class_vptr. */
2490 se
->class_vptr
= gfc_class_vptr_get (decl
);
2493 se
->class_vptr
= NULL_TREE
;
2495 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2496 decl
, field
, NULL_TREE
);
2500 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2501 strlen () conditional below. */
2502 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2503 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2504 && !c
->attr
.pdt_string
)
2506 tmp
= c
->ts
.u
.cl
->backend_decl
;
2507 /* Components must always be constant length. */
2508 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2509 se
->string_length
= tmp
;
2512 if (gfc_deferred_strlen (c
, &field
))
2514 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2516 decl
, field
, NULL_TREE
);
2517 se
->string_length
= tmp
;
2520 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2521 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2522 && c
->ts
.type
!= BT_CHARACTER
)
2523 || c
->attr
.proc_pointer
)
2524 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2529 /* This function deals with component references to components of the
2530 parent type for derived type extensions. */
2532 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2540 c
= ref
->u
.c
.component
;
2542 /* Return if the component is in the parent type. */
2543 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2544 if (strcmp (c
->name
, cmp
->name
) == 0)
2547 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2548 parent
.type
= REF_COMPONENT
;
2550 parent
.u
.c
.sym
= dt
;
2551 parent
.u
.c
.component
= dt
->components
;
2553 if (dt
->backend_decl
== NULL
)
2554 gfc_get_derived_type (dt
);
2556 /* Build the reference and call self. */
2557 gfc_conv_component_ref (se
, &parent
);
2558 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2559 parent
.u
.c
.component
= c
;
2560 conv_parent_component_references (se
, &parent
);
2565 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2567 tree res
= se
->expr
;
2572 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2573 TREE_TYPE (TREE_TYPE (res
)), res
);
2577 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2578 TREE_TYPE (TREE_TYPE (res
)), res
);
2582 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2587 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2597 /* Dereference VAR where needed if it is a pointer, reference, etc.
2598 according to Fortran semantics. */
2601 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2604 /* Characters are entirely different from other types, they are treated
2606 if (sym
->ts
.type
== BT_CHARACTER
)
2608 /* Dereference character pointer dummy arguments
2610 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2612 || sym
->attr
.function
2613 || sym
->attr
.result
))
2614 var
= build_fold_indirect_ref_loc (input_location
, var
);
2616 else if (!sym
->attr
.value
)
2618 /* Dereference temporaries for class array dummy arguments. */
2619 if (sym
->attr
.dummy
&& is_classarray
2620 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2622 if (!descriptor_only_p
)
2623 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2625 var
= build_fold_indirect_ref_loc (input_location
, var
);
2628 /* Dereference non-character scalar dummy arguments. */
2629 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2630 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2631 && (sym
->ts
.type
!= BT_CLASS
2632 || (!CLASS_DATA (sym
)->attr
.dimension
2633 && !(CLASS_DATA (sym
)->attr
.codimension
2634 && CLASS_DATA (sym
)->attr
.allocatable
))))
2635 var
= build_fold_indirect_ref_loc (input_location
, var
);
2637 /* Dereference scalar hidden result. */
2638 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2639 && (sym
->attr
.function
|| sym
->attr
.result
)
2640 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2641 && !sym
->attr
.always_explicit
)
2642 var
= build_fold_indirect_ref_loc (input_location
, var
);
2644 /* Dereference non-character, non-class pointer variables.
2645 These must be dummies, results, or scalars. */
2647 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2648 || gfc_is_associate_pointer (sym
)
2649 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2651 || sym
->attr
.function
2653 || (!sym
->attr
.dimension
2654 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2655 var
= build_fold_indirect_ref_loc (input_location
, var
);
2656 /* Now treat the class array pointer variables accordingly. */
2657 else if (sym
->ts
.type
== BT_CLASS
2659 && (CLASS_DATA (sym
)->attr
.dimension
2660 || CLASS_DATA (sym
)->attr
.codimension
)
2661 && ((CLASS_DATA (sym
)->as
2662 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2663 || CLASS_DATA (sym
)->attr
.allocatable
2664 || CLASS_DATA (sym
)->attr
.class_pointer
))
2665 var
= build_fold_indirect_ref_loc (input_location
, var
);
2666 /* And the case where a non-dummy, non-result, non-function,
2667 non-allotable and non-pointer classarray is present. This case was
2668 previously covered by the first if, but with introducing the
2669 condition !is_classarray there, that case has to be covered
2671 else if (sym
->ts
.type
== BT_CLASS
2673 && !sym
->attr
.function
2674 && !sym
->attr
.result
2675 && (CLASS_DATA (sym
)->attr
.dimension
2676 || CLASS_DATA (sym
)->attr
.codimension
)
2678 || !CLASS_DATA (sym
)->attr
.allocatable
)
2679 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2680 var
= build_fold_indirect_ref_loc (input_location
, var
);
2686 /* Return the contents of a variable. Also handles reference/pointer
2687 variables (all Fortran pointer references are implicit). */
2690 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2695 tree parent_decl
= NULL_TREE
;
2698 bool alternate_entry
;
2701 bool first_time
= true;
2703 sym
= expr
->symtree
->n
.sym
;
2704 is_classarray
= IS_CLASS_ARRAY (sym
);
2708 gfc_ss_info
*ss_info
= ss
->info
;
2710 /* Check that something hasn't gone horribly wrong. */
2711 gcc_assert (ss
!= gfc_ss_terminator
);
2712 gcc_assert (ss_info
->expr
== expr
);
2714 /* A scalarized term. We already know the descriptor. */
2715 se
->expr
= ss_info
->data
.array
.descriptor
;
2716 se
->string_length
= ss_info
->string_length
;
2717 ref
= ss_info
->data
.array
.ref
;
2719 gcc_assert (ref
->type
== REF_ARRAY
2720 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2722 gfc_conv_tmp_array_ref (se
);
2726 tree se_expr
= NULL_TREE
;
2728 se
->expr
= gfc_get_symbol_decl (sym
);
2730 /* Deal with references to a parent results or entries by storing
2731 the current_function_decl and moving to the parent_decl. */
2732 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2733 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2734 && sym
->result
== sym
;
2735 entry_master
= sym
->attr
.result
2736 && sym
->ns
->proc_name
->attr
.entry_master
2737 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2738 if (current_function_decl
)
2739 parent_decl
= DECL_CONTEXT (current_function_decl
);
2741 if ((se
->expr
== parent_decl
&& return_value
)
2742 || (sym
->ns
&& sym
->ns
->proc_name
2744 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2745 && (alternate_entry
|| entry_master
)))
2750 /* Special case for assigning the return value of a function.
2751 Self recursive functions must have an explicit return value. */
2752 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2753 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2755 /* Similarly for alternate entry points. */
2756 else if (alternate_entry
2757 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2760 gfc_entry_list
*el
= NULL
;
2762 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2765 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2770 else if (entry_master
2771 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2773 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2778 /* Procedure actual arguments. Look out for temporary variables
2779 with the same attributes as function values. */
2780 else if (!sym
->attr
.temporary
2781 && sym
->attr
.flavor
== FL_PROCEDURE
2782 && se
->expr
!= current_function_decl
)
2784 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2786 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2787 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2792 /* Dereference the expression, where needed. */
2793 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
2799 /* For character variables, also get the length. */
2800 if (sym
->ts
.type
== BT_CHARACTER
)
2802 /* If the character length of an entry isn't set, get the length from
2803 the master function instead. */
2804 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2805 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2807 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2808 gcc_assert (se
->string_length
);
2811 gfc_typespec
*ts
= &sym
->ts
;
2817 /* Return the descriptor if that's what we want and this is an array
2818 section reference. */
2819 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2821 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2822 /* Return the descriptor for array pointers and allocations. */
2823 if (se
->want_pointer
2824 && ref
->next
== NULL
&& (se
->descriptor_only
))
2827 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2828 /* Return a pointer to an element. */
2832 ts
= &ref
->u
.c
.component
->ts
;
2833 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2834 && se
->descriptor_only
2835 && !CLASS_DATA (sym
)->attr
.allocatable
2836 && !CLASS_DATA (sym
)->attr
.class_pointer
2837 && CLASS_DATA (sym
)->as
2838 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2839 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2840 /* Skip the first ref of a _data component, because for class
2841 arrays that one is already done by introducing a temporary
2842 array descriptor. */
2845 if (ref
->u
.c
.sym
->attr
.extension
)
2846 conv_parent_component_references (se
, ref
);
2848 gfc_conv_component_ref (se
, ref
);
2849 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2850 && se
->want_pointer
&& se
->descriptor_only
)
2856 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2857 expr
->symtree
->name
, &expr
->where
);
2861 conv_inquiry (se
, ref
, expr
, ts
);
2871 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2873 if (se
->want_pointer
)
2875 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2876 gfc_conv_string_parameter (se
);
2878 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2883 /* Unary ops are easy... Or they would be if ! was a valid op. */
2886 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2891 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2892 /* Initialize the operand. */
2893 gfc_init_se (&operand
, se
);
2894 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2895 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2897 type
= gfc_typenode_for_spec (&expr
->ts
);
2899 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2900 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2901 All other unary operators have an equivalent GIMPLE unary operator. */
2902 if (code
== TRUTH_NOT_EXPR
)
2903 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2904 build_int_cst (type
, 0));
2906 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2910 /* Expand power operator to optimal multiplications when a value is raised
2911 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2912 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2913 Programming", 3rd Edition, 1998. */
2915 /* This code is mostly duplicated from expand_powi in the backend.
2916 We establish the "optimal power tree" lookup table with the defined size.
2917 The items in the table are the exponents used to calculate the index
2918 exponents. Any integer n less than the value can get an "addition chain",
2919 with the first node being one. */
2920 #define POWI_TABLE_SIZE 256
2922 /* The table is from builtins.c. */
2923 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2925 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2926 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2927 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2928 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2929 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2930 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2931 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2932 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2933 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2934 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2935 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2936 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2937 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2938 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2939 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2940 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2941 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2942 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2943 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2944 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2945 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2946 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2947 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2948 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2949 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2950 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2951 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2952 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2953 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2954 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2955 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2956 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2959 /* If n is larger than lookup table's max index, we use the "window
2961 #define POWI_WINDOW_SIZE 3
2963 /* Recursive function to expand the power operator. The temporary
2964 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2966 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2973 if (n
< POWI_TABLE_SIZE
)
2978 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2979 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2983 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2984 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2985 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2989 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2993 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2994 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2996 if (n
< POWI_TABLE_SIZE
)
3003 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3004 return 1. Else return 0 and a call to runtime library functions
3005 will have to be built. */
3007 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3012 tree vartmp
[POWI_TABLE_SIZE
];
3014 unsigned HOST_WIDE_INT n
;
3016 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3018 /* If exponent is too large, we won't expand it anyway, so don't bother
3019 with large integer values. */
3020 if (!wi::fits_shwi_p (wrhs
))
3023 m
= wrhs
.to_shwi ();
3024 /* Use the wide_int's routine to reliably get the absolute value on all
3025 platforms. Then convert it to a HOST_WIDE_INT like above. */
3026 n
= wi::abs (wrhs
).to_shwi ();
3028 type
= TREE_TYPE (lhs
);
3029 sgn
= tree_int_cst_sgn (rhs
);
3031 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3032 || optimize_size
) && (m
> 2 || m
< -1))
3038 se
->expr
= gfc_build_const (type
, integer_one_node
);
3042 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3043 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3045 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3046 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3047 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3048 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3051 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3054 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3055 logical_type_node
, tmp
, cond
);
3056 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3057 tmp
, build_int_cst (type
, 1),
3058 build_int_cst (type
, 0));
3062 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3063 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3064 build_int_cst (type
, -1),
3065 build_int_cst (type
, 0));
3066 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3067 cond
, build_int_cst (type
, 1), tmp
);
3071 memset (vartmp
, 0, sizeof (vartmp
));
3075 tmp
= gfc_build_const (type
, integer_one_node
);
3076 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3080 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3086 /* Power op (**). Constant integer exponent has special handling. */
3089 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3091 tree gfc_int4_type_node
;
3094 int res_ikind_1
, res_ikind_2
;
3099 gfc_init_se (&lse
, se
);
3100 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3101 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3102 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3104 gfc_init_se (&rse
, se
);
3105 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3106 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3108 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3109 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3110 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3113 if (INTEGER_CST_P (lse
.expr
)
3114 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3116 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3118 int kind
, ikind
, bit_size
;
3120 v
= wlhs
.to_shwi ();
3123 kind
= expr
->value
.op
.op1
->ts
.kind
;
3124 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3125 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3129 /* 1**something is always 1. */
3130 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3135 /* (-1)**n is 1 - ((n & 1) << 1) */
3139 type
= TREE_TYPE (lse
.expr
);
3140 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3141 rse
.expr
, build_int_cst (type
, 1));
3142 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3143 tmp
, build_int_cst (type
, 1));
3144 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3145 build_int_cst (type
, 1), tmp
);
3149 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3151 /* Here v is +/- 2**e. The further simplification uses
3152 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3153 1<<(4*n), etc., but we have to make sure to return zero
3154 if the number of bits is too large. */
3164 type
= TREE_TYPE (lse
.expr
);
3169 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3170 TREE_TYPE (rse
.expr
),
3171 rse
.expr
, rse
.expr
);
3174 /* use popcount for fast log2(w) */
3175 int e
= wi::popcount (w
-1);
3176 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3177 TREE_TYPE (rse
.expr
),
3178 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3182 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3183 build_int_cst (type
, 1), shift
);
3184 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3185 rse
.expr
, build_int_cst (type
, 0));
3186 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3187 build_int_cst (type
, 0));
3188 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3189 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3190 rse
.expr
, num_bits
);
3191 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3192 build_int_cst (type
, 0), cond
);
3199 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3201 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3202 rse
.expr
, build_int_cst (type
, 1));
3203 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3204 tmp2
, build_int_cst (type
, 1));
3205 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3206 build_int_cst (type
, 1), tmp2
);
3207 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3214 gfc_int4_type_node
= gfc_get_int_type (4);
3216 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3217 library routine. But in the end, we have to convert the result back
3218 if this case applies -- with res_ikind_K, we keep track whether operand K
3219 falls into this case. */
3223 kind
= expr
->value
.op
.op1
->ts
.kind
;
3224 switch (expr
->value
.op
.op2
->ts
.type
)
3227 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3232 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3233 res_ikind_2
= ikind
;
3255 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3257 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3284 switch (expr
->value
.op
.op1
->ts
.type
)
3287 if (kind
== 3) /* Case 16 was not handled properly above. */
3289 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3293 /* Use builtins for real ** int4. */
3299 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3303 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3307 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3311 /* Use the __builtin_powil() only if real(kind=16) is
3312 actually the C long double type. */
3313 if (!gfc_real16_is_float128
)
3314 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3322 /* If we don't have a good builtin for this, go for the
3323 library function. */
3325 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3329 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3338 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3342 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3350 se
->expr
= build_call_expr_loc (input_location
,
3351 fndecl
, 2, lse
.expr
, rse
.expr
);
3353 /* Convert the result back if it is of wrong integer kind. */
3354 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3356 /* We want the maximum of both operand kinds as result. */
3357 if (res_ikind_1
< res_ikind_2
)
3358 res_ikind_1
= res_ikind_2
;
3359 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3364 /* Generate code to allocate a string temporary. */
3367 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3372 if (gfc_can_put_var_on_stack (len
))
3374 /* Create a temporary variable to hold the result. */
3375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3376 TREE_TYPE (len
), len
,
3377 build_int_cst (TREE_TYPE (len
), 1));
3378 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3380 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3381 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3383 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3385 var
= gfc_create_var (tmp
, "str");
3386 var
= gfc_build_addr_expr (type
, var
);
3390 /* Allocate a temporary to hold the result. */
3391 var
= gfc_create_var (type
, "pstr");
3392 gcc_assert (POINTER_TYPE_P (type
));
3393 tmp
= TREE_TYPE (type
);
3394 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3395 tmp
= TREE_TYPE (tmp
);
3396 tmp
= TYPE_SIZE_UNIT (tmp
);
3397 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3398 fold_convert (size_type_node
, len
),
3399 fold_convert (size_type_node
, tmp
));
3400 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3401 gfc_add_modify (&se
->pre
, var
, tmp
);
3403 /* Free the temporary afterwards. */
3404 tmp
= gfc_call_free (var
);
3405 gfc_add_expr_to_block (&se
->post
, tmp
);
3412 /* Handle a string concatenation operation. A temporary will be allocated to
3416 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3419 tree len
, type
, var
, tmp
, fndecl
;
3421 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3422 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3423 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3425 gfc_init_se (&lse
, se
);
3426 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3427 gfc_conv_string_parameter (&lse
);
3428 gfc_init_se (&rse
, se
);
3429 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3430 gfc_conv_string_parameter (&rse
);
3432 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3433 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3435 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3436 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3437 if (len
== NULL_TREE
)
3439 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3440 gfc_charlen_type_node
,
3441 fold_convert (gfc_charlen_type_node
,
3443 fold_convert (gfc_charlen_type_node
,
3444 rse
.string_length
));
3447 type
= build_pointer_type (type
);
3449 var
= gfc_conv_string_tmp (se
, type
, len
);
3451 /* Do the actual concatenation. */
3452 if (expr
->ts
.kind
== 1)
3453 fndecl
= gfor_fndecl_concat_string
;
3454 else if (expr
->ts
.kind
== 4)
3455 fndecl
= gfor_fndecl_concat_string_char4
;
3459 tmp
= build_call_expr_loc (input_location
,
3460 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3461 rse
.string_length
, rse
.expr
);
3462 gfc_add_expr_to_block (&se
->pre
, tmp
);
3464 /* Add the cleanup for the operands. */
3465 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3466 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3469 se
->string_length
= len
;
3472 /* Translates an op expression. Common (binary) cases are handled by this
3473 function, others are passed on. Recursion is used in either case.
3474 We use the fact that (op1.ts == op2.ts) (except for the power
3476 Operators need no special handling for scalarized expressions as long as
3477 they call gfc_conv_simple_val to get their operands.
3478 Character strings get special handling. */
3481 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3483 enum tree_code code
;
3492 switch (expr
->value
.op
.op
)
3494 case INTRINSIC_PARENTHESES
:
3495 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3496 && flag_protect_parens
)
3498 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3499 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3504 case INTRINSIC_UPLUS
:
3505 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3508 case INTRINSIC_UMINUS
:
3509 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3513 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3516 case INTRINSIC_PLUS
:
3520 case INTRINSIC_MINUS
:
3524 case INTRINSIC_TIMES
:
3528 case INTRINSIC_DIVIDE
:
3529 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3530 an integer, we must round towards zero, so we use a
3532 if (expr
->ts
.type
== BT_INTEGER
)
3533 code
= TRUNC_DIV_EXPR
;
3538 case INTRINSIC_POWER
:
3539 gfc_conv_power_op (se
, expr
);
3542 case INTRINSIC_CONCAT
:
3543 gfc_conv_concat_op (se
, expr
);
3547 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3552 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3556 /* EQV and NEQV only work on logicals, but since we represent them
3557 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3559 case INTRINSIC_EQ_OS
:
3567 case INTRINSIC_NE_OS
:
3568 case INTRINSIC_NEQV
:
3575 case INTRINSIC_GT_OS
:
3582 case INTRINSIC_GE_OS
:
3589 case INTRINSIC_LT_OS
:
3596 case INTRINSIC_LE_OS
:
3602 case INTRINSIC_USER
:
3603 case INTRINSIC_ASSIGN
:
3604 /* These should be converted into function calls by the frontend. */
3608 fatal_error (input_location
, "Unknown intrinsic op");
3612 /* The only exception to this is **, which is handled separately anyway. */
3613 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3615 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3619 gfc_init_se (&lse
, se
);
3620 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3621 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3624 gfc_init_se (&rse
, se
);
3625 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3626 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3630 gfc_conv_string_parameter (&lse
);
3631 gfc_conv_string_parameter (&rse
);
3633 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3634 rse
.string_length
, rse
.expr
,
3635 expr
->value
.op
.op1
->ts
.kind
,
3637 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3638 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3641 type
= gfc_typenode_for_spec (&expr
->ts
);
3645 /* The result of logical ops is always logical_type_node. */
3646 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3647 lse
.expr
, rse
.expr
);
3648 se
->expr
= convert (type
, tmp
);
3651 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3653 /* Add the post blocks. */
3654 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3655 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3658 /* If a string's length is one, we convert it to a single character. */
3661 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3665 || !tree_fits_uhwi_p (len
)
3666 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3669 if (TREE_INT_CST_LOW (len
) == 1)
3671 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3672 return build_fold_indirect_ref_loc (input_location
, str
);
3676 && TREE_CODE (str
) == ADDR_EXPR
3677 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3678 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3679 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3680 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3681 && TREE_INT_CST_LOW (len
) > 1
3682 && TREE_INT_CST_LOW (len
)
3683 == (unsigned HOST_WIDE_INT
)
3684 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3686 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3687 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3688 if (TREE_CODE (ret
) == INTEGER_CST
)
3690 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3691 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3692 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3694 for (i
= 1; i
< length
; i
++)
3707 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3710 if (sym
->backend_decl
)
3712 /* This becomes the nominal_type in
3713 function.c:assign_parm_find_data_types. */
3714 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3715 /* This becomes the passed_type in
3716 function.c:assign_parm_find_data_types. C promotes char to
3717 integer for argument passing. */
3718 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3720 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3725 /* If we have a constant character expression, make it into an
3727 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3732 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3733 (int)(*expr
)->value
.character
.string
[0]);
3734 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3736 /* The expr needs to be compatible with a C int. If the
3737 conversion fails, then the 2 causes an ICE. */
3738 ts
.type
= BT_INTEGER
;
3739 ts
.kind
= gfc_c_int_kind
;
3740 gfc_convert_type (*expr
, &ts
, 2);
3743 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3745 if ((*expr
)->ref
== NULL
)
3747 se
->expr
= gfc_string_to_single_character
3748 (build_int_cst (integer_type_node
, 1),
3749 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3751 ((*expr
)->symtree
->n
.sym
)),
3756 gfc_conv_variable (se
, *expr
);
3757 se
->expr
= gfc_string_to_single_character
3758 (build_int_cst (integer_type_node
, 1),
3759 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3767 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3768 if STR is a string literal, otherwise return -1. */
3771 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3774 && TREE_CODE (str
) == ADDR_EXPR
3775 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3776 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3777 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3778 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3779 && tree_fits_uhwi_p (len
)
3780 && tree_to_uhwi (len
) >= 1
3781 && tree_to_uhwi (len
)
3782 == (unsigned HOST_WIDE_INT
)
3783 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3785 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3786 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3787 if (TREE_CODE (folded
) == INTEGER_CST
)
3789 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3790 int length
= TREE_STRING_LENGTH (string_cst
);
3791 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3793 for (; length
> 0; length
--)
3794 if (ptr
[length
- 1] != ' ')
3803 /* Helper to build a call to memcmp. */
3806 build_memcmp_call (tree s1
, tree s2
, tree n
)
3810 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3811 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3813 s1
= fold_convert (pvoid_type_node
, s1
);
3815 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3816 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3818 s2
= fold_convert (pvoid_type_node
, s2
);
3820 n
= fold_convert (size_type_node
, n
);
3822 tmp
= build_call_expr_loc (input_location
,
3823 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3826 return fold_convert (integer_type_node
, tmp
);
3829 /* Compare two strings. If they are all single characters, the result is the
3830 subtraction of them. Otherwise, we build a library call. */
3833 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3834 enum tree_code code
)
3840 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3841 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3843 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3844 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3846 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3848 /* Deal with single character specially. */
3849 sc1
= fold_convert (integer_type_node
, sc1
);
3850 sc2
= fold_convert (integer_type_node
, sc2
);
3851 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3855 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3857 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3859 /* If one string is a string literal with LEN_TRIM longer
3860 than the length of the second string, the strings
3862 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3863 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3864 return integer_one_node
;
3865 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3866 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3867 return integer_one_node
;
3870 /* We can compare via memcpy if the strings are known to be equal
3871 in length and they are
3873 - kind=4 and the comparison is for (in)equality. */
3875 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3876 && tree_int_cst_equal (len1
, len2
)
3877 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3882 chartype
= gfc_get_char_type (kind
);
3883 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3884 fold_convert (TREE_TYPE(len1
),
3885 TYPE_SIZE_UNIT(chartype
)),
3887 return build_memcmp_call (str1
, str2
, tmp
);
3890 /* Build a call for the comparison. */
3892 fndecl
= gfor_fndecl_compare_string
;
3894 fndecl
= gfor_fndecl_compare_string_char4
;
3898 return build_call_expr_loc (input_location
, fndecl
, 4,
3899 len1
, str1
, len2
, str2
);
3903 /* Return the backend_decl for a procedure pointer component. */
3906 get_proc_ptr_comp (gfc_expr
*e
)
3912 gfc_init_se (&comp_se
, NULL
);
3913 e2
= gfc_copy_expr (e
);
3914 /* We have to restore the expr type later so that gfc_free_expr frees
3915 the exact same thing that was allocated.
3916 TODO: This is ugly. */
3917 old_type
= e2
->expr_type
;
3918 e2
->expr_type
= EXPR_VARIABLE
;
3919 gfc_conv_expr (&comp_se
, e2
);
3920 e2
->expr_type
= old_type
;
3922 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3926 /* Convert a typebound function reference from a class object. */
3928 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3933 if (!VAR_P (base_object
))
3935 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3936 gfc_add_modify (&se
->pre
, var
, base_object
);
3938 se
->expr
= gfc_class_vptr_get (base_object
);
3939 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3941 while (ref
&& ref
->next
)
3943 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3944 if (ref
->u
.c
.sym
->attr
.extension
)
3945 conv_parent_component_references (se
, ref
);
3946 gfc_conv_component_ref (se
, ref
);
3947 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3952 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
3953 gfc_actual_arglist
*actual_args
)
3957 if (gfc_is_proc_ptr_comp (expr
))
3958 tmp
= get_proc_ptr_comp (expr
);
3959 else if (sym
->attr
.dummy
)
3961 tmp
= gfc_get_symbol_decl (sym
);
3962 if (sym
->attr
.proc_pointer
)
3963 tmp
= build_fold_indirect_ref_loc (input_location
,
3965 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3966 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3970 if (!sym
->backend_decl
)
3971 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
3973 TREE_USED (sym
->backend_decl
) = 1;
3975 tmp
= sym
->backend_decl
;
3977 if (sym
->attr
.cray_pointee
)
3979 /* TODO - make the cray pointee a pointer to a procedure,
3980 assign the pointer to it and use it for the call. This
3982 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3983 gfc_get_symbol_decl (sym
->cp_pointer
));
3984 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3987 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3989 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3990 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3997 /* Initialize MAPPING. */
4000 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
4002 mapping
->syms
= NULL
;
4003 mapping
->charlens
= NULL
;
4007 /* Free all memory held by MAPPING (but not MAPPING itself). */
4010 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4012 gfc_interface_sym_mapping
*sym
;
4013 gfc_interface_sym_mapping
*nextsym
;
4015 gfc_charlen
*nextcl
;
4017 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4019 nextsym
= sym
->next
;
4020 sym
->new_sym
->n
.sym
->formal
= NULL
;
4021 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4022 gfc_free_expr (sym
->expr
);
4023 free (sym
->new_sym
);
4026 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4029 gfc_free_expr (cl
->length
);
4035 /* Return a copy of gfc_charlen CL. Add the returned structure to
4036 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4038 static gfc_charlen
*
4039 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4042 gfc_charlen
*new_charlen
;
4044 new_charlen
= gfc_get_charlen ();
4045 new_charlen
->next
= mapping
->charlens
;
4046 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4048 mapping
->charlens
= new_charlen
;
4053 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4054 array variable that can be used as the actual argument for dummy
4055 argument SYM. Add any initialization code to BLOCK. PACKED is as
4056 for gfc_get_nodesc_array_type and DATA points to the first element
4057 in the passed array. */
4060 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4061 gfc_packed packed
, tree data
)
4066 type
= gfc_typenode_for_spec (&sym
->ts
);
4067 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4068 !sym
->attr
.target
&& !sym
->attr
.pointer
4069 && !sym
->attr
.proc_pointer
);
4071 var
= gfc_create_var (type
, "ifm");
4072 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4078 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4079 and offset of descriptorless array type TYPE given that it has the same
4080 size as DESC. Add any set-up code to BLOCK. */
4083 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4090 offset
= gfc_index_zero_node
;
4091 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4093 dim
= gfc_rank_cst
[n
];
4094 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4095 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4097 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4098 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4099 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4100 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4102 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4104 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4105 gfc_array_index_type
,
4106 gfc_conv_descriptor_ubound_get (desc
, dim
),
4107 gfc_conv_descriptor_lbound_get (desc
, dim
));
4108 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4109 gfc_array_index_type
,
4110 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4111 tmp
= gfc_evaluate_now (tmp
, block
);
4112 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4114 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4115 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4116 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4117 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4118 gfc_array_index_type
, offset
, tmp
);
4120 offset
= gfc_evaluate_now (offset
, block
);
4121 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4125 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4126 in SE. The caller may still use se->expr and se->string_length after
4127 calling this function. */
4130 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4131 gfc_symbol
* sym
, gfc_se
* se
,
4134 gfc_interface_sym_mapping
*sm
;
4138 gfc_symbol
*new_sym
;
4140 gfc_symtree
*new_symtree
;
4142 /* Create a new symbol to represent the actual argument. */
4143 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4144 new_sym
->ts
= sym
->ts
;
4145 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4146 new_sym
->attr
.referenced
= 1;
4147 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4148 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4149 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4150 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4151 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4152 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4153 new_sym
->attr
.function
= sym
->attr
.function
;
4155 /* Ensure that the interface is available and that
4156 descriptors are passed for array actual arguments. */
4157 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4159 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4160 new_sym
->attr
.always_explicit
4161 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4164 /* Create a fake symtree for it. */
4166 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4167 new_symtree
->n
.sym
= new_sym
;
4168 gcc_assert (new_symtree
== root
);
4170 /* Create a dummy->actual mapping. */
4171 sm
= XCNEW (gfc_interface_sym_mapping
);
4172 sm
->next
= mapping
->syms
;
4174 sm
->new_sym
= new_symtree
;
4175 sm
->expr
= gfc_copy_expr (expr
);
4178 /* Stabilize the argument's value. */
4179 if (!sym
->attr
.function
&& se
)
4180 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4182 if (sym
->ts
.type
== BT_CHARACTER
)
4184 /* Create a copy of the dummy argument's length. */
4185 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4186 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4188 /* If the length is specified as "*", record the length that
4189 the caller is passing. We should use the callee's length
4190 in all other cases. */
4191 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4193 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4194 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4201 /* Use the passed value as-is if the argument is a function. */
4202 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4205 /* If the argument is a pass-by-value scalar, use the value as is. */
4206 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4209 /* If the argument is either a string or a pointer to a string,
4210 convert it to a boundless character type. */
4211 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4213 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4214 tmp
= build_pointer_type (tmp
);
4215 if (sym
->attr
.pointer
)
4216 value
= build_fold_indirect_ref_loc (input_location
,
4220 value
= fold_convert (tmp
, value
);
4223 /* If the argument is a scalar, a pointer to an array or an allocatable,
4225 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4226 value
= build_fold_indirect_ref_loc (input_location
,
4229 /* For character(*), use the actual argument's descriptor. */
4230 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4231 value
= build_fold_indirect_ref_loc (input_location
,
4234 /* If the argument is an array descriptor, use it to determine
4235 information about the actual argument's shape. */
4236 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4237 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4239 /* Get the actual argument's descriptor. */
4240 desc
= build_fold_indirect_ref_loc (input_location
,
4243 /* Create the replacement variable. */
4244 tmp
= gfc_conv_descriptor_data_get (desc
);
4245 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4248 /* Use DESC to work out the upper bounds, strides and offset. */
4249 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4252 /* Otherwise we have a packed array. */
4253 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4254 PACKED_FULL
, se
->expr
);
4256 new_sym
->backend_decl
= value
;
4260 /* Called once all dummy argument mappings have been added to MAPPING,
4261 but before the mapping is used to evaluate expressions. Pre-evaluate
4262 the length of each argument, adding any initialization code to PRE and
4263 any finalization code to POST. */
4266 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4267 stmtblock_t
* pre
, stmtblock_t
* post
)
4269 gfc_interface_sym_mapping
*sym
;
4273 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4274 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4275 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4277 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4278 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4279 gfc_init_se (&se
, NULL
);
4280 gfc_conv_expr (&se
, expr
);
4281 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4282 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4283 gfc_add_block_to_block (pre
, &se
.pre
);
4284 gfc_add_block_to_block (post
, &se
.post
);
4286 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4291 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4295 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4296 gfc_constructor_base base
)
4299 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4301 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4304 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4305 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4306 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4312 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4316 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4321 for (; ref
; ref
= ref
->next
)
4325 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4327 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4328 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4329 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4338 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4339 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4345 /* Convert intrinsic function calls into result expressions. */
4348 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4356 arg1
= expr
->value
.function
.actual
->expr
;
4357 if (expr
->value
.function
.actual
->next
)
4358 arg2
= expr
->value
.function
.actual
->next
->expr
;
4362 sym
= arg1
->symtree
->n
.sym
;
4364 if (sym
->attr
.dummy
)
4369 switch (expr
->value
.function
.isym
->id
)
4372 /* TODO figure out why this condition is necessary. */
4373 if (sym
->attr
.function
4374 && (arg1
->ts
.u
.cl
->length
== NULL
4375 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4376 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4379 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4382 case GFC_ISYM_LEN_TRIM
:
4383 new_expr
= gfc_copy_expr (arg1
);
4384 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4389 gfc_replace_expr (arg1
, new_expr
);
4393 if (!sym
->as
|| sym
->as
->rank
== 0)
4396 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4398 dup
= mpz_get_si (arg2
->value
.integer
);
4403 dup
= sym
->as
->rank
;
4407 for (; d
< dup
; d
++)
4411 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4413 gfc_free_expr (new_expr
);
4417 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4418 gfc_get_int_expr (gfc_default_integer_kind
,
4420 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4422 new_expr
= gfc_multiply (new_expr
, tmp
);
4428 case GFC_ISYM_LBOUND
:
4429 case GFC_ISYM_UBOUND
:
4430 /* TODO These implementations of lbound and ubound do not limit if
4431 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4433 if (!sym
->as
|| sym
->as
->rank
== 0)
4436 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4437 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4441 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4443 if (sym
->as
->lower
[d
])
4444 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4448 if (sym
->as
->upper
[d
])
4449 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4457 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4461 gfc_replace_expr (expr
, new_expr
);
4467 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4468 gfc_interface_mapping
* mapping
)
4470 gfc_formal_arglist
*f
;
4471 gfc_actual_arglist
*actual
;
4473 actual
= expr
->value
.function
.actual
;
4474 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4476 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4481 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4484 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4489 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4491 for (d
= 0; d
< as
->rank
; d
++)
4493 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4494 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4497 expr
->value
.function
.esym
->as
= as
;
4500 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4502 expr
->value
.function
.esym
->ts
.u
.cl
->length
4503 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4505 gfc_apply_interface_mapping_to_expr (mapping
,
4506 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4511 /* EXPR is a copy of an expression that appeared in the interface
4512 associated with MAPPING. Walk it recursively looking for references to
4513 dummy arguments that MAPPING maps to actual arguments. Replace each such
4514 reference with a reference to the associated actual argument. */
4517 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4520 gfc_interface_sym_mapping
*sym
;
4521 gfc_actual_arglist
*actual
;
4526 /* Copying an expression does not copy its length, so do that here. */
4527 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4529 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4530 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4533 /* Apply the mapping to any references. */
4534 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4536 /* ...and to the expression's symbol, if it has one. */
4537 /* TODO Find out why the condition on expr->symtree had to be moved into
4538 the loop rather than being outside it, as originally. */
4539 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4540 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4542 if (sym
->new_sym
->n
.sym
->backend_decl
)
4543 expr
->symtree
= sym
->new_sym
;
4545 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4548 /* ...and to subexpressions in expr->value. */
4549 switch (expr
->expr_type
)
4554 case EXPR_SUBSTRING
:
4558 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4559 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4563 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4564 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4566 if (expr
->value
.function
.esym
== NULL
4567 && expr
->value
.function
.isym
!= NULL
4568 && expr
->value
.function
.actual
4569 && expr
->value
.function
.actual
->expr
4570 && expr
->value
.function
.actual
->expr
->symtree
4571 && gfc_map_intrinsic_function (expr
, mapping
))
4574 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4575 if (sym
->old
== expr
->value
.function
.esym
)
4577 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4578 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4579 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4584 case EXPR_STRUCTURE
:
4585 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4599 /* Evaluate interface expression EXPR using MAPPING. Store the result
4603 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4604 gfc_se
* se
, gfc_expr
* expr
)
4606 expr
= gfc_copy_expr (expr
);
4607 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4608 gfc_conv_expr (se
, expr
);
4609 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4610 gfc_free_expr (expr
);
4614 /* Returns a reference to a temporary array into which a component of
4615 an actual argument derived type array is copied and then returned
4616 after the function call. */
4618 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4619 sym_intent intent
, bool formal_ptr
,
4620 const gfc_symbol
*fsym
, const char *proc_name
,
4621 gfc_symbol
*sym
, bool check_contiguous
)
4629 gfc_array_info
*info
;
4642 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4644 if (pass_optional
|| check_contiguous
)
4646 gfc_init_se (&work_se
, NULL
);
4652 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4654 /* We will create a temporary array, so let us warn. */
4657 if (fsym
&& proc_name
)
4658 msg
= xasprintf ("An array temporary was created for argument "
4659 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4661 msg
= xasprintf ("An array temporary was created");
4663 tmp
= build_int_cst (logical_type_node
, 1);
4664 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4669 gfc_init_se (&lse
, NULL
);
4670 gfc_init_se (&rse
, NULL
);
4672 /* Walk the argument expression. */
4673 rss
= gfc_walk_expr (expr
);
4675 gcc_assert (rss
!= gfc_ss_terminator
);
4677 /* Initialize the scalarizer. */
4678 gfc_init_loopinfo (&loop
);
4679 gfc_add_ss_to_loop (&loop
, rss
);
4681 /* Calculate the bounds of the scalarization. */
4682 gfc_conv_ss_startstride (&loop
);
4684 /* Build an ss for the temporary. */
4685 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4686 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4688 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4689 if (GFC_ARRAY_TYPE_P (base_type
)
4690 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4691 base_type
= gfc_get_element_type (base_type
);
4693 if (expr
->ts
.type
== BT_CLASS
)
4694 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4696 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4697 ? expr
->ts
.u
.cl
->backend_decl
4701 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4703 /* Associate the SS with the loop. */
4704 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4706 /* Setup the scalarizing loops. */
4707 gfc_conv_loop_setup (&loop
, &expr
->where
);
4709 /* Pass the temporary descriptor back to the caller. */
4710 info
= &loop
.temp_ss
->info
->data
.array
;
4711 parmse
->expr
= info
->descriptor
;
4713 /* Setup the gfc_se structures. */
4714 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4715 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4718 lse
.ss
= loop
.temp_ss
;
4719 gfc_mark_ss_chain_used (rss
, 1);
4720 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4722 /* Start the scalarized loop body. */
4723 gfc_start_scalarized_body (&loop
, &body
);
4725 /* Translate the expression. */
4726 gfc_conv_expr (&rse
, expr
);
4728 /* Reset the offset for the function call since the loop
4729 is zero based on the data pointer. Note that the temp
4730 comes first in the loop chain since it is added second. */
4731 if (gfc_is_class_array_function (expr
))
4733 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4734 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4735 gfc_index_zero_node
);
4738 gfc_conv_tmp_array_ref (&lse
);
4740 if (intent
!= INTENT_OUT
)
4742 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4743 gfc_add_expr_to_block (&body
, tmp
);
4744 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4745 gfc_trans_scalarizing_loops (&loop
, &body
);
4749 /* Make sure that the temporary declaration survives by merging
4750 all the loop declarations into the current context. */
4751 for (n
= 0; n
< loop
.dimen
; n
++)
4753 gfc_merge_block_scope (&body
);
4754 body
= loop
.code
[loop
.order
[n
]];
4756 gfc_merge_block_scope (&body
);
4759 /* Add the post block after the second loop, so that any
4760 freeing of allocated memory is done at the right time. */
4761 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4763 /**********Copy the temporary back again.*********/
4765 gfc_init_se (&lse
, NULL
);
4766 gfc_init_se (&rse
, NULL
);
4768 /* Walk the argument expression. */
4769 lss
= gfc_walk_expr (expr
);
4770 rse
.ss
= loop
.temp_ss
;
4773 /* Initialize the scalarizer. */
4774 gfc_init_loopinfo (&loop2
);
4775 gfc_add_ss_to_loop (&loop2
, lss
);
4777 dimen
= rse
.ss
->dimen
;
4779 /* Skip the write-out loop for this case. */
4780 if (gfc_is_class_array_function (expr
))
4781 goto class_array_fcn
;
4783 /* Calculate the bounds of the scalarization. */
4784 gfc_conv_ss_startstride (&loop2
);
4786 /* Setup the scalarizing loops. */
4787 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4789 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4790 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4792 gfc_mark_ss_chain_used (lss
, 1);
4793 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4795 /* Declare the variable to hold the temporary offset and start the
4796 scalarized loop body. */
4797 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4798 gfc_start_scalarized_body (&loop2
, &body
);
4800 /* Build the offsets for the temporary from the loop variables. The
4801 temporary array has lbounds of zero and strides of one in all
4802 dimensions, so this is very simple. The offset is only computed
4803 outside the innermost loop, so the overall transfer could be
4804 optimized further. */
4805 info
= &rse
.ss
->info
->data
.array
;
4807 tmp_index
= gfc_index_zero_node
;
4808 for (n
= dimen
- 1; n
> 0; n
--)
4811 tmp
= rse
.loop
->loopvar
[n
];
4812 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4813 tmp
, rse
.loop
->from
[n
]);
4814 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4817 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4818 gfc_array_index_type
,
4819 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4820 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4821 gfc_array_index_type
,
4822 tmp_str
, gfc_index_one_node
);
4824 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4825 gfc_array_index_type
, tmp
, tmp_str
);
4828 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4829 gfc_array_index_type
,
4830 tmp_index
, rse
.loop
->from
[0]);
4831 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4833 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4834 gfc_array_index_type
,
4835 rse
.loop
->loopvar
[0], offset
);
4837 /* Now use the offset for the reference. */
4838 tmp
= build_fold_indirect_ref_loc (input_location
,
4840 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4842 if (expr
->ts
.type
== BT_CHARACTER
)
4843 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4845 gfc_conv_expr (&lse
, expr
);
4847 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4849 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4850 gfc_add_expr_to_block (&body
, tmp
);
4852 /* Generate the copying loops. */
4853 gfc_trans_scalarizing_loops (&loop2
, &body
);
4855 /* Wrap the whole thing up by adding the second loop to the post-block
4856 and following it by the post-block of the first loop. In this way,
4857 if the temporary needs freeing, it is done after use! */
4858 if (intent
!= INTENT_IN
)
4860 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4861 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4866 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4868 gfc_cleanup_loop (&loop
);
4869 gfc_cleanup_loop (&loop2
);
4871 /* Pass the string length to the argument expression. */
4872 if (expr
->ts
.type
== BT_CHARACTER
)
4873 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4875 /* Determine the offset for pointer formal arguments and set the
4879 size
= gfc_index_one_node
;
4880 offset
= gfc_index_zero_node
;
4881 for (n
= 0; n
< dimen
; n
++)
4883 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4885 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4886 gfc_array_index_type
, tmp
,
4887 gfc_index_one_node
);
4888 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4892 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4895 gfc_index_one_node
);
4896 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4897 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4898 gfc_array_index_type
,
4900 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4901 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4902 gfc_array_index_type
,
4903 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4904 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4905 gfc_array_index_type
,
4906 tmp
, gfc_index_one_node
);
4907 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4908 gfc_array_index_type
, size
, tmp
);
4911 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4915 /* We want either the address for the data or the address of the descriptor,
4916 depending on the mode of passing array arguments. */
4918 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4920 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4922 /* Basically make this into
4933 pointer = parmse->expr;
4940 if (present && !contiguous)
4945 if (pass_optional
|| check_contiguous
)
4948 stmtblock_t else_block
;
4949 tree pre_stmts
, post_stmts
;
4952 tree present_var
= NULL_TREE
;
4953 tree cont_var
= NULL_TREE
;
4956 type
= TREE_TYPE (parmse
->expr
);
4957 pointer
= gfc_create_var (type
, "arg_ptr");
4959 if (check_contiguous
)
4961 gfc_se cont_se
, array_se
;
4962 stmtblock_t if_block
, else_block
;
4963 tree if_stmt
, else_stmt
;
4967 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
4969 /* If the size is known to be one at compile-time, set
4970 cont_var to true unconditionally. This may look
4971 inelegant, but we're only doing this during
4972 optimization, so the statements will be optimized away,
4973 and this saves complexity here. */
4975 size_set
= gfc_array_size (expr
, &size
);
4976 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
4978 gfc_add_modify (&se
->pre
, cont_var
,
4979 build_one_cst (boolean_type_node
));
4983 /* cont_var = is_contiguous (expr); . */
4984 gfc_init_se (&cont_se
, parmse
);
4985 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
4986 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
4987 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
4988 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
4994 /* arrayse->expr = descriptor of a. */
4995 gfc_init_se (&array_se
, se
);
4996 gfc_conv_expr_descriptor (&array_se
, expr
);
4997 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
4998 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
5000 /* if_stmt = { pointer = &a[0]; } . */
5001 gfc_init_block (&if_block
);
5002 tmp
= gfc_conv_array_data (array_se
.expr
);
5003 tmp
= fold_convert (type
, tmp
);
5004 gfc_add_modify (&if_block
, pointer
, tmp
);
5005 if_stmt
= gfc_finish_block (&if_block
);
5007 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5008 gfc_init_block (&else_block
);
5009 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
5010 gfc_add_modify (&else_block
, pointer
, parmse
->expr
);
5011 else_stmt
= gfc_finish_block (&else_block
);
5013 /* And put the above into an if statement. */
5014 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5015 gfc_likely (cont_var
,
5016 PRED_FORTRAN_CONTIGUOUS
),
5017 if_stmt
, else_stmt
);
5021 /* pointer = pramse->expr; . */
5022 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5023 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5028 present_var
= gfc_create_var (boolean_type_node
, "present");
5030 /* present_var = present(sym); . */
5031 tmp
= gfc_conv_expr_present (sym
);
5032 tmp
= fold_convert (boolean_type_node
, tmp
);
5033 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5035 /* else_stmt = { pointer = NULL; } . */
5036 gfc_init_block (&else_block
);
5037 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5038 else_stmt
= gfc_finish_block (&else_block
);
5040 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5041 gfc_likely (present_var
,
5042 PRED_FORTRAN_ABSENT_DUMMY
),
5043 pre_stmts
, else_stmt
);
5044 gfc_add_expr_to_block (&se
->pre
, tmp
);
5047 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5049 post_stmts
= gfc_finish_block (&parmse
->post
);
5051 /* Put together the post stuff, plus the optional
5053 if (check_contiguous
)
5056 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5058 build_zero_cst (boolean_type_node
));
5059 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5063 tree present_likely
= gfc_likely (present_var
,
5064 PRED_FORTRAN_ABSENT_DUMMY
);
5065 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5066 boolean_type_node
, present_likely
,
5074 gcc_assert (pass_optional
);
5075 post_cond
= present_var
;
5078 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5079 post_stmts
, build_empty_stmt (input_location
));
5080 gfc_add_expr_to_block (&se
->post
, tmp
);
5088 /* Generate the code for argument list functions. */
5091 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5093 /* Pass by value for g77 %VAL(arg), pass the address
5094 indirectly for %LOC, else by reference. Thus %REF
5095 is a "do-nothing" and %LOC is the same as an F95
5097 if (strcmp (name
, "%VAL") == 0)
5098 gfc_conv_expr (se
, expr
);
5099 else if (strcmp (name
, "%LOC") == 0)
5101 gfc_conv_expr_reference (se
, expr
);
5102 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5104 else if (strcmp (name
, "%REF") == 0)
5105 gfc_conv_expr_reference (se
, expr
);
5107 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5111 /* This function tells whether the middle-end representation of the expression
5112 E given as input may point to data otherwise accessible through a variable
5114 It is assumed that the only expressions that may alias are variables,
5115 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5117 This function is used to decide whether freeing an expression's allocatable
5118 components is safe or should be avoided.
5120 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5121 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5122 is necessary because for array constructors, aliasing depends on how
5124 - If E is an array constructor used as argument to an elemental procedure,
5125 the array, which is generated through shallow copy by the scalarizer,
5126 is used directly and can alias the expressions it was copied from.
5127 - If E is an array constructor used as argument to a non-elemental
5128 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5129 the array as in the previous case, but then that array is used
5130 to initialize a new descriptor through deep copy. There is no alias
5131 possible in that case.
5132 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5136 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5140 if (e
->expr_type
== EXPR_VARIABLE
)
5142 else if (e
->expr_type
== EXPR_FUNCTION
)
5144 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5146 if (proc_ifc
->result
!= NULL
5147 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5148 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5149 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5150 || proc_ifc
->result
->attr
.pointer
))
5155 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5158 for (c
= gfc_constructor_first (e
->value
.constructor
);
5159 c
; c
= gfc_constructor_next (c
))
5161 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5168 /* A helper function to set the dtype for unallocated or unassociated
5172 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5180 /* TODO Figure out how to handle optional dummies. */
5181 if (e
&& e
->expr_type
== EXPR_VARIABLE
5182 && e
->symtree
->n
.sym
->attr
.optional
)
5185 desc
= parmse
->expr
;
5186 if (desc
== NULL_TREE
)
5189 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5190 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5192 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5195 gfc_init_block (&block
);
5196 tmp
= gfc_conv_descriptor_data_get (desc
);
5197 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5198 logical_type_node
, tmp
,
5199 build_int_cst (TREE_TYPE (tmp
), 0));
5200 tmp
= gfc_conv_descriptor_dtype (desc
);
5201 type
= gfc_get_element_type (TREE_TYPE (desc
));
5202 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5203 TREE_TYPE (tmp
), tmp
,
5204 gfc_get_dtype_rank_type (e
->rank
, type
));
5205 gfc_add_expr_to_block (&block
, tmp
);
5206 cond
= build3_v (COND_EXPR
, cond
,
5207 gfc_finish_block (&block
),
5208 build_empty_stmt (input_location
));
5209 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5214 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5215 ISO_Fortran_binding array descriptors. */
5218 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5228 symbol_attribute attr
= gfc_expr_attr (e
);
5230 /* If this is a full array or a scalar, the allocatable and pointer
5231 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5233 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
5237 else if (attr
.allocatable
)
5241 /* If the formal argument is assumed shape and neither a pointer nor
5242 allocatable, it is unconditionally CFI_attribute_other. */
5243 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
5244 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)
5247 cfi_attribute
= attribute
;
5251 parmse
->force_no_tmp
= 1;
5252 if (fsym
->attr
.contiguous
5253 && !gfc_is_simply_contiguous (e
, false, true))
5254 gfc_conv_subref_array_arg (parmse
, e
, false, fsym
->attr
.intent
,
5255 fsym
->attr
.pointer
);
5257 gfc_conv_expr_descriptor (parmse
, e
);
5259 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5260 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5262 bool is_artificial
= (INDIRECT_REF_P (parmse
->expr
)
5263 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse
->expr
, 0))
5264 : DECL_ARTIFICIAL (parmse
->expr
));
5266 /* Unallocated allocatable arrays and unassociated pointer arrays
5267 need their dtype setting if they are argument associated with
5268 assumed rank dummies. */
5269 if (fsym
&& fsym
->as
5270 && (gfc_expr_attr (e
).pointer
5271 || gfc_expr_attr (e
).allocatable
))
5272 set_dtype_for_unallocated (parmse
, e
);
5274 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5275 the expression type is different from the descriptor type, then
5276 the offset must be found (eg. to a component ref or substring)
5277 and the dtype updated. Assumed type entities are only allowed
5278 to be dummies in Fortran. They therefore lack the decl specific
5279 appendiges and so must be treated differently from other fortran
5280 entities passed to CFI descriptors in the interface decl. */
5281 type
= e
->ts
.type
!= BT_ASSUMED
? gfc_typenode_for_spec (&e
->ts
) :
5284 if (type
&& is_artificial
5285 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
5287 /* Obtain the offset to the data. */
5288 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
5289 gfc_index_zero_node
, true, e
);
5291 /* Update the dtype. */
5292 gfc_add_modify (&parmse
->pre
,
5293 gfc_conv_descriptor_dtype (parmse
->expr
),
5294 gfc_get_dtype_rank_type (e
->rank
, type
));
5296 else if (type
== NULL_TREE
5297 || (!is_subref_array (e
) && !is_artificial
))
5299 /* Make sure that the span is set for expressions where it
5300 might not have been done already. */
5301 tmp
= gfc_conv_descriptor_elem_len (parmse
->expr
);
5302 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5303 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
5308 gfc_conv_expr (parmse
, e
);
5310 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5311 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5314 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
5315 parmse
->expr
, attr
);
5318 /* Set the CFI attribute field through a temporary value for the
5320 desc_attr
= gfc_conv_descriptor_attribute (parmse
->expr
);
5321 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5322 void_type_node
, desc_attr
,
5323 build_int_cst (TREE_TYPE (desc_attr
), cfi_attribute
));
5324 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5326 /* Now pass the gfc_descriptor by reference. */
5327 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5329 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5330 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5331 gfc_desc_ptr
= parmse
->expr
;
5332 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
5333 gfc_add_modify (&parmse
->pre
, cfi_desc_ptr
, null_pointer_node
);
5335 /* Allocate the CFI descriptor itself and fill the fields. */
5336 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
5337 tmp
= build_call_expr_loc (input_location
,
5338 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
5339 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5341 /* Now set the gfc descriptor attribute. */
5342 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5343 void_type_node
, desc_attr
,
5344 build_int_cst (TREE_TYPE (desc_attr
), attribute
));
5345 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5347 /* The CFI descriptor is passed to the bind_C procedure. */
5348 parmse
->expr
= cfi_desc_ptr
;
5350 /* Free the CFI descriptor. */
5351 tmp
= gfc_call_free (cfi_desc_ptr
);
5352 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5354 /* Transfer values back to gfc descriptor. */
5355 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5356 tmp
= build_call_expr_loc (input_location
,
5357 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
5358 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5360 /* Deal with an optional dummy being passed to an optional formal arg
5361 by finishing the pre and post blocks and making their execution
5362 conditional on the dummy being present. */
5363 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5364 && e
->symtree
->n
.sym
->attr
.optional
)
5366 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5367 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5369 build_int_cst (pvoid_type_node
, 0));
5370 tmp
= build3_v (COND_EXPR
, cond
,
5371 gfc_finish_block (&parmse
->pre
), tmp
);
5372 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5373 tmp
= build3_v (COND_EXPR
, cond
,
5374 gfc_finish_block (&parmse
->post
),
5375 build_empty_stmt (input_location
));
5376 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5381 /* Generate code for a procedure call. Note can return se->post != NULL.
5382 If se->direct_byref is set then se->expr contains the return parameter.
5383 Return nonzero, if the call has alternate specifiers.
5384 'expr' is only needed for procedure pointer components. */
5387 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5388 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5389 vec
<tree
, va_gc
> *append_args
)
5391 gfc_interface_mapping mapping
;
5392 vec
<tree
, va_gc
> *arglist
;
5393 vec
<tree
, va_gc
> *retargs
;
5397 gfc_array_info
*info
;
5404 vec
<tree
, va_gc
> *stringargs
;
5405 vec
<tree
, va_gc
> *optionalargs
;
5407 gfc_formal_arglist
*formal
;
5408 gfc_actual_arglist
*arg
;
5409 int has_alternate_specifier
= 0;
5410 bool need_interface_mapping
;
5418 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5419 gfc_component
*comp
= NULL
;
5426 optionalargs
= NULL
;
5431 comp
= gfc_get_proc_ptr_comp (expr
);
5433 bool elemental_proc
= (comp
5434 && comp
->ts
.interface
5435 && comp
->ts
.interface
->attr
.elemental
)
5436 || (comp
&& comp
->attr
.elemental
)
5437 || sym
->attr
.elemental
;
5441 if (!elemental_proc
)
5443 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5444 if (se
->ss
->info
->useflags
)
5446 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5447 && sym
->result
->attr
.dimension
)
5448 || (comp
&& comp
->attr
.dimension
)
5449 || gfc_is_class_array_function (expr
));
5450 gcc_assert (se
->loop
!= NULL
);
5451 /* Access the previously obtained result. */
5452 gfc_conv_tmp_array_ref (se
);
5456 info
= &se
->ss
->info
->data
.array
;
5461 gfc_init_block (&post
);
5462 gfc_init_interface_mapping (&mapping
);
5465 formal
= gfc_sym_get_dummy_args (sym
);
5466 need_interface_mapping
= sym
->attr
.dimension
||
5467 (sym
->ts
.type
== BT_CHARACTER
5468 && sym
->ts
.u
.cl
->length
5469 && sym
->ts
.u
.cl
->length
->expr_type
5474 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5475 need_interface_mapping
= comp
->attr
.dimension
||
5476 (comp
->ts
.type
== BT_CHARACTER
5477 && comp
->ts
.u
.cl
->length
5478 && comp
->ts
.u
.cl
->length
->expr_type
5482 base_object
= NULL_TREE
;
5483 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5484 is the third and fourth argument to such a function call a value
5485 denoting the number of elements to copy (i.e., most of the time the
5486 length of a deferred length string). */
5487 ulim_copy
= (formal
== NULL
)
5488 && UNLIMITED_POLY (sym
)
5489 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5491 /* Evaluate the arguments. */
5492 for (arg
= args
, argc
= 0; arg
!= NULL
;
5493 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5495 bool finalized
= false;
5496 bool non_unity_length_string
= false;
5499 fsym
= formal
? formal
->sym
: NULL
;
5500 parm_kind
= MISSING
;
5502 if (fsym
&& fsym
->ts
.type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
5503 && (!fsym
->ts
.u
.cl
->length
5504 || fsym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5505 || mpz_cmp_si (fsym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5506 non_unity_length_string
= true;
5508 /* If the procedure requires an explicit interface, the actual
5509 argument is passed according to the corresponding formal
5510 argument. If the corresponding formal argument is a POINTER,
5511 ALLOCATABLE or assumed shape, we do not use g77's calling
5512 convention, and pass the address of the array descriptor
5513 instead. Otherwise we use g77's calling convention, in other words
5514 pass the array data pointer without descriptor. */
5515 bool nodesc_arg
= fsym
!= NULL
5516 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5518 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5519 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5521 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5523 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5525 /* Class array expressions are sometimes coming completely unadorned
5526 with either arrayspec or _data component. Correct that here.
5527 OOP-TODO: Move this to the frontend. */
5528 if (e
&& e
->expr_type
== EXPR_VARIABLE
5530 && e
->ts
.type
== BT_CLASS
5531 && (CLASS_DATA (e
)->attr
.codimension
5532 || CLASS_DATA (e
)->attr
.dimension
))
5534 gfc_typespec temp_ts
= e
->ts
;
5535 gfc_add_class_array_ref (e
);
5541 if (se
->ignore_optional
)
5543 /* Some intrinsics have already been resolved to the correct
5547 else if (arg
->label
)
5549 has_alternate_specifier
= 1;
5554 gfc_init_se (&parmse
, NULL
);
5556 /* For scalar arguments with VALUE attribute which are passed by
5557 value, pass "0" and a hidden argument gives the optional
5559 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5560 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5561 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5563 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5565 vec_safe_push (optionalargs
, boolean_false_node
);
5569 /* Pass a NULL pointer for an absent arg. */
5570 parmse
.expr
= null_pointer_node
;
5571 if (arg
->missing_arg_type
== BT_CHARACTER
)
5572 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5577 else if (arg
->expr
->expr_type
== EXPR_NULL
5578 && fsym
&& !fsym
->attr
.pointer
5579 && (fsym
->ts
.type
!= BT_CLASS
5580 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5582 /* Pass a NULL pointer to denote an absent arg. */
5583 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5584 && (fsym
->ts
.type
!= BT_CLASS
5585 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5586 gfc_init_se (&parmse
, NULL
);
5587 parmse
.expr
= null_pointer_node
;
5588 if (arg
->missing_arg_type
== BT_CHARACTER
)
5589 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5591 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5592 && e
->ts
.type
== BT_DERIVED
)
5594 /* The derived type needs to be converted to a temporary
5596 gfc_init_se (&parmse
, se
);
5597 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5599 && e
->expr_type
== EXPR_VARIABLE
5600 && e
->symtree
->n
.sym
->attr
.optional
,
5601 CLASS_DATA (fsym
)->attr
.class_pointer
5602 || CLASS_DATA (fsym
)->attr
.allocatable
);
5604 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
5606 /* The intrinsic type needs to be converted to a temporary
5607 CLASS object for the unlimited polymorphic formal. */
5608 gfc_init_se (&parmse
, se
);
5609 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5611 else if (se
->ss
&& se
->ss
->info
->useflags
)
5617 /* An elemental function inside a scalarized loop. */
5618 gfc_init_se (&parmse
, se
);
5619 parm_kind
= ELEMENTAL
;
5621 /* When no fsym is present, ulim_copy is set and this is a third or
5622 fourth argument, use call-by-value instead of by reference to
5623 hand the length properties to the copy routine (i.e., most of the
5624 time this will be a call to a __copy_character_* routine where the
5625 third and fourth arguments are the lengths of a deferred length
5627 if ((fsym
&& fsym
->attr
.value
)
5628 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5629 gfc_conv_expr (&parmse
, e
);
5631 gfc_conv_expr_reference (&parmse
, e
);
5633 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5634 && e
->expr_type
== EXPR_FUNCTION
)
5635 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5638 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5639 && gfc_is_class_container_ref (e
))
5641 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5643 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5644 && e
->symtree
->n
.sym
->attr
.optional
)
5646 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5647 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5648 TREE_TYPE (parmse
.expr
),
5650 fold_convert (TREE_TYPE (parmse
.expr
),
5651 null_pointer_node
));
5655 /* If we are passing an absent array as optional dummy to an
5656 elemental procedure, make sure that we pass NULL when the data
5657 pointer is NULL. We need this extra conditional because of
5658 scalarization which passes arrays elements to the procedure,
5659 ignoring the fact that the array can be absent/unallocated/... */
5660 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5662 tree descriptor_data
;
5664 descriptor_data
= ss
->info
->data
.array
.data
;
5665 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5667 fold_convert (TREE_TYPE (descriptor_data
),
5668 null_pointer_node
));
5670 = fold_build3_loc (input_location
, COND_EXPR
,
5671 TREE_TYPE (parmse
.expr
),
5672 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5673 fold_convert (TREE_TYPE (parmse
.expr
),
5678 /* The scalarizer does not repackage the reference to a class
5679 array - instead it returns a pointer to the data element. */
5680 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5681 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5682 fsym
->attr
.intent
!= INTENT_IN
5683 && (CLASS_DATA (fsym
)->attr
.class_pointer
5684 || CLASS_DATA (fsym
)->attr
.allocatable
),
5686 && e
->expr_type
== EXPR_VARIABLE
5687 && e
->symtree
->n
.sym
->attr
.optional
,
5688 CLASS_DATA (fsym
)->attr
.class_pointer
5689 || CLASS_DATA (fsym
)->attr
.allocatable
);
5696 gfc_init_se (&parmse
, NULL
);
5698 /* Check whether the expression is a scalar or not; we cannot use
5699 e->rank as it can be nonzero for functions arguments. */
5700 argss
= gfc_walk_expr (e
);
5701 scalar
= argss
== gfc_ss_terminator
;
5703 gfc_free_ss_chain (argss
);
5705 /* Special handling for passing scalar polymorphic coarrays;
5706 otherwise one passes "class->_data.data" instead of "&class". */
5707 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5708 && fsym
&& fsym
->ts
.type
== BT_CLASS
5709 && CLASS_DATA (fsym
)->attr
.codimension
5710 && !CLASS_DATA (fsym
)->attr
.dimension
)
5712 gfc_add_class_array_ref (e
);
5713 parmse
.want_coarray
= 1;
5717 /* A scalar or transformational function. */
5720 if (e
->expr_type
== EXPR_VARIABLE
5721 && e
->symtree
->n
.sym
->attr
.cray_pointee
5722 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5724 /* The Cray pointer needs to be converted to a pointer to
5725 a type given by the expression. */
5726 gfc_conv_expr (&parmse
, e
);
5727 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5728 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5729 parmse
.expr
= convert (type
, tmp
);
5732 else if (sym
->attr
.is_bind_c
&& e
5733 && (is_CFI_desc (fsym
, NULL
)
5734 || non_unity_length_string
))
5735 /* Implement F2018, C.12.6.1: paragraph (2). */
5736 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5738 else if (fsym
&& fsym
->attr
.value
)
5740 if (fsym
->ts
.type
== BT_CHARACTER
5741 && fsym
->ts
.is_c_interop
5742 && fsym
->ns
->proc_name
!= NULL
5743 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5746 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5747 if (parmse
.expr
== NULL
)
5748 gfc_conv_expr (&parmse
, e
);
5752 gfc_conv_expr (&parmse
, e
);
5753 if (fsym
->attr
.optional
5754 && fsym
->ts
.type
!= BT_CLASS
5755 && fsym
->ts
.type
!= BT_DERIVED
)
5757 if (e
->expr_type
!= EXPR_VARIABLE
5758 || !e
->symtree
->n
.sym
->attr
.optional
5760 vec_safe_push (optionalargs
, boolean_true_node
);
5763 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5764 if (!e
->symtree
->n
.sym
->attr
.value
)
5766 = fold_build3_loc (input_location
, COND_EXPR
,
5767 TREE_TYPE (parmse
.expr
),
5769 fold_convert (TREE_TYPE (parmse
.expr
),
5770 integer_zero_node
));
5772 vec_safe_push (optionalargs
,
5773 fold_convert (boolean_type_node
,
5780 else if (arg
->name
&& arg
->name
[0] == '%')
5781 /* Argument list functions %VAL, %LOC and %REF are signalled
5782 through arg->name. */
5783 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5784 else if ((e
->expr_type
== EXPR_FUNCTION
)
5785 && ((e
->value
.function
.esym
5786 && e
->value
.function
.esym
->result
->attr
.pointer
)
5787 || (!e
->value
.function
.esym
5788 && e
->symtree
->n
.sym
->attr
.pointer
))
5789 && fsym
&& fsym
->attr
.target
)
5791 gfc_conv_expr (&parmse
, e
);
5792 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5795 else if (e
->expr_type
== EXPR_FUNCTION
5796 && e
->symtree
->n
.sym
->result
5797 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5798 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5800 /* Functions returning procedure pointers. */
5801 gfc_conv_expr (&parmse
, e
);
5802 if (fsym
&& fsym
->attr
.proc_pointer
)
5803 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5808 if (e
->ts
.type
== BT_CLASS
&& fsym
5809 && fsym
->ts
.type
== BT_CLASS
5810 && (!CLASS_DATA (fsym
)->as
5811 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5812 && CLASS_DATA (e
)->attr
.codimension
)
5814 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5815 gcc_assert (!CLASS_DATA (fsym
)->as
);
5816 gfc_add_class_array_ref (e
);
5817 parmse
.want_coarray
= 1;
5818 gfc_conv_expr_reference (&parmse
, e
);
5819 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5821 && e
->expr_type
== EXPR_VARIABLE
);
5823 else if (e
->ts
.type
== BT_CLASS
&& fsym
5824 && fsym
->ts
.type
== BT_CLASS
5825 && !CLASS_DATA (fsym
)->as
5826 && !CLASS_DATA (e
)->as
5827 && strcmp (fsym
->ts
.u
.derived
->name
,
5828 e
->ts
.u
.derived
->name
))
5830 type
= gfc_typenode_for_spec (&fsym
->ts
);
5831 var
= gfc_create_var (type
, fsym
->name
);
5832 gfc_conv_expr (&parmse
, e
);
5833 if (fsym
->attr
.optional
5834 && e
->expr_type
== EXPR_VARIABLE
5835 && e
->symtree
->n
.sym
->attr
.optional
)
5839 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5840 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5841 logical_type_node
, tmp
,
5842 fold_convert (TREE_TYPE (tmp
),
5843 null_pointer_node
));
5844 gfc_start_block (&block
);
5845 gfc_add_modify (&block
, var
,
5846 fold_build1_loc (input_location
,
5848 type
, parmse
.expr
));
5849 gfc_add_expr_to_block (&parmse
.pre
,
5850 fold_build3_loc (input_location
,
5851 COND_EXPR
, void_type_node
,
5852 cond
, gfc_finish_block (&block
),
5853 build_empty_stmt (input_location
)));
5854 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5855 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5856 TREE_TYPE (parmse
.expr
),
5858 fold_convert (TREE_TYPE (parmse
.expr
),
5859 null_pointer_node
));
5863 /* Since the internal representation of unlimited
5864 polymorphic expressions includes an extra field
5865 that other class objects do not, a cast to the
5866 formal type does not work. */
5867 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5871 /* Set the _data field. */
5872 tmp
= gfc_class_data_get (var
);
5873 efield
= fold_convert (TREE_TYPE (tmp
),
5874 gfc_class_data_get (parmse
.expr
));
5875 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5877 /* Set the _vptr field. */
5878 tmp
= gfc_class_vptr_get (var
);
5879 efield
= fold_convert (TREE_TYPE (tmp
),
5880 gfc_class_vptr_get (parmse
.expr
));
5881 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5883 /* Set the _len field. */
5884 tmp
= gfc_class_len_get (var
);
5885 gfc_add_modify (&parmse
.pre
, tmp
,
5886 build_int_cst (TREE_TYPE (tmp
), 0));
5890 tmp
= fold_build1_loc (input_location
,
5893 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5896 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5902 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5903 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5904 && !e
->symtree
->n
.sym
->attr
.dimension
5905 && !e
->symtree
->n
.sym
->attr
.pointer
5907 && !e
->symtree
->n
.sym
->attr
.dummy
5908 /* FIXME - PR 87395 and PR 41453 */
5909 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5910 && !e
->symtree
->n
.sym
->attr
.associate_var
5911 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5912 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5914 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5916 /* Catch base objects that are not variables. */
5917 if (e
->ts
.type
== BT_CLASS
5918 && e
->expr_type
!= EXPR_VARIABLE
5919 && expr
&& e
== expr
->base_expr
)
5920 base_object
= build_fold_indirect_ref_loc (input_location
,
5923 /* A class array element needs converting back to be a
5924 class object, if the formal argument is a class object. */
5925 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5926 && e
->ts
.type
== BT_CLASS
5927 && ((CLASS_DATA (fsym
)->as
5928 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5929 || CLASS_DATA (e
)->attr
.dimension
))
5930 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5931 fsym
->attr
.intent
!= INTENT_IN
5932 && (CLASS_DATA (fsym
)->attr
.class_pointer
5933 || CLASS_DATA (fsym
)->attr
.allocatable
),
5935 && e
->expr_type
== EXPR_VARIABLE
5936 && e
->symtree
->n
.sym
->attr
.optional
,
5937 CLASS_DATA (fsym
)->attr
.class_pointer
5938 || CLASS_DATA (fsym
)->attr
.allocatable
);
5940 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5941 allocated on entry, it must be deallocated. */
5942 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5943 && (fsym
->attr
.allocatable
5944 || (fsym
->ts
.type
== BT_CLASS
5945 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5950 gfc_init_block (&block
);
5952 if (e
->ts
.type
== BT_CLASS
)
5953 ptr
= gfc_class_data_get (ptr
);
5955 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5958 gfc_add_expr_to_block (&block
, tmp
);
5959 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5960 void_type_node
, ptr
,
5962 gfc_add_expr_to_block (&block
, tmp
);
5964 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5966 gfc_add_modify (&block
, ptr
,
5967 fold_convert (TREE_TYPE (ptr
),
5968 null_pointer_node
));
5969 gfc_add_expr_to_block (&block
, tmp
);
5971 else if (fsym
->ts
.type
== BT_CLASS
)
5974 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5975 tmp
= gfc_get_symbol_decl (vtab
);
5976 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5977 ptr
= gfc_class_vptr_get (parmse
.expr
);
5978 gfc_add_modify (&block
, ptr
,
5979 fold_convert (TREE_TYPE (ptr
), tmp
));
5980 gfc_add_expr_to_block (&block
, tmp
);
5983 if (fsym
->attr
.optional
5984 && e
->expr_type
== EXPR_VARIABLE
5985 && e
->symtree
->n
.sym
->attr
.optional
)
5987 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5989 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5990 gfc_finish_block (&block
),
5991 build_empty_stmt (input_location
));
5994 tmp
= gfc_finish_block (&block
);
5996 gfc_add_expr_to_block (&se
->pre
, tmp
);
5999 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
6000 || fsym
->ts
.type
== BT_ASSUMED
)
6001 && e
->ts
.type
== BT_CLASS
6002 && !CLASS_DATA (e
)->attr
.dimension
6003 && !CLASS_DATA (e
)->attr
.codimension
)
6005 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6006 /* The result is a class temporary, whose _data component
6007 must be freed to avoid a memory leak. */
6008 if (e
->expr_type
== EXPR_FUNCTION
6009 && CLASS_DATA (e
)->attr
.allocatable
)
6015 /* Borrow the function symbol to make a call to
6016 gfc_add_finalizer_call and then restore it. */
6017 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6018 e
->symtree
->n
.sym
->backend_decl
6019 = TREE_OPERAND (parmse
.expr
, 0);
6020 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6021 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6022 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6024 gfc_free_expr (var
);
6025 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6026 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6028 /* Then free the class _data. */
6029 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6030 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6033 tmp
= build3_v (COND_EXPR
, tmp
,
6034 gfc_call_free (parmse
.expr
),
6035 build_empty_stmt (input_location
));
6036 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6037 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6041 /* Wrap scalar variable in a descriptor. We need to convert
6042 the address of a pointer back to the pointer itself before,
6043 we can assign it to the data field. */
6045 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6046 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6049 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6050 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6051 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6053 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6056 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6057 && ((fsym
->attr
.pointer
6058 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6059 || (fsym
->attr
.proc_pointer
6060 && !(e
->expr_type
== EXPR_VARIABLE
6061 && e
->symtree
->n
.sym
->attr
.dummy
))
6062 || (fsym
->attr
.proc_pointer
6063 && e
->expr_type
== EXPR_VARIABLE
6064 && gfc_is_proc_ptr_comp (e
))
6065 || (fsym
->attr
.allocatable
6066 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6068 /* Scalar pointer dummy args require an extra level of
6069 indirection. The null pointer already contains
6070 this level of indirection. */
6071 parm_kind
= SCALAR_POINTER
;
6072 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6076 else if (e
->ts
.type
== BT_CLASS
6077 && fsym
&& fsym
->ts
.type
== BT_CLASS
6078 && (CLASS_DATA (fsym
)->attr
.dimension
6079 || CLASS_DATA (fsym
)->attr
.codimension
))
6081 /* Pass a class array. */
6082 parmse
.use_offset
= 1;
6083 gfc_conv_expr_descriptor (&parmse
, e
);
6085 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6086 allocated on entry, it must be deallocated. */
6087 if (fsym
->attr
.intent
== INTENT_OUT
6088 && CLASS_DATA (fsym
)->attr
.allocatable
)
6093 gfc_init_block (&block
);
6095 ptr
= gfc_class_data_get (ptr
);
6097 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6098 NULL_TREE
, NULL_TREE
,
6100 GFC_CAF_COARRAY_NOCOARRAY
);
6101 gfc_add_expr_to_block (&block
, tmp
);
6102 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6103 void_type_node
, ptr
,
6105 gfc_add_expr_to_block (&block
, tmp
);
6106 gfc_reset_vptr (&block
, e
);
6108 if (fsym
->attr
.optional
6109 && e
->expr_type
== EXPR_VARIABLE
6111 || (e
->ref
->type
== REF_ARRAY
6112 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6113 && e
->symtree
->n
.sym
->attr
.optional
)
6115 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6117 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6118 gfc_finish_block (&block
),
6119 build_empty_stmt (input_location
));
6122 tmp
= gfc_finish_block (&block
);
6124 gfc_add_expr_to_block (&se
->pre
, tmp
);
6127 /* The conversion does not repackage the reference to a class
6128 array - _data descriptor. */
6129 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6130 fsym
->attr
.intent
!= INTENT_IN
6131 && (CLASS_DATA (fsym
)->attr
.class_pointer
6132 || CLASS_DATA (fsym
)->attr
.allocatable
),
6134 && e
->expr_type
== EXPR_VARIABLE
6135 && e
->symtree
->n
.sym
->attr
.optional
,
6136 CLASS_DATA (fsym
)->attr
.class_pointer
6137 || CLASS_DATA (fsym
)->attr
.allocatable
);
6141 /* If the argument is a function call that may not create
6142 a temporary for the result, we have to check that we
6143 can do it, i.e. that there is no alias between this
6144 argument and another one. */
6145 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6151 intent
= fsym
->attr
.intent
;
6153 intent
= INTENT_UNKNOWN
;
6155 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6157 parmse
.force_tmp
= 1;
6159 iarg
= e
->value
.function
.actual
->expr
;
6161 /* Temporary needed if aliasing due to host association. */
6162 if (sym
->attr
.contained
6164 && !sym
->attr
.implicit_pure
6165 && !sym
->attr
.use_assoc
6166 && iarg
->expr_type
== EXPR_VARIABLE
6167 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6168 parmse
.force_tmp
= 1;
6170 /* Ditto within module. */
6171 if (sym
->attr
.use_assoc
6173 && !sym
->attr
.implicit_pure
6174 && iarg
->expr_type
== EXPR_VARIABLE
6175 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6176 parmse
.force_tmp
= 1;
6179 if (sym
->attr
.is_bind_c
&& e
6180 && (is_CFI_desc (fsym
, NULL
) || non_unity_length_string
))
6181 /* Implement F2018, C.12.6.1: paragraph (2). */
6182 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6184 else if (e
->expr_type
== EXPR_VARIABLE
6185 && is_subref_array (e
)
6186 && !(fsym
&& fsym
->attr
.pointer
))
6187 /* The actual argument is a component reference to an
6188 array of derived types. In this case, the argument
6189 is converted to a temporary, which is passed and then
6190 written back after the procedure call. */
6191 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6192 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6193 fsym
&& fsym
->attr
.pointer
);
6195 else if (gfc_is_class_array_ref (e
, NULL
)
6196 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6197 /* The actual argument is a component reference to an
6198 array of derived types. In this case, the argument
6199 is converted to a temporary, which is passed and then
6200 written back after the procedure call.
6201 OOP-TODO: Insert code so that if the dynamic type is
6202 the same as the declared type, copy-in/copy-out does
6204 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6206 fsym
->attr
.pointer
);
6208 else if (gfc_is_class_array_function (e
)
6209 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6210 /* See previous comment. For function actual argument,
6211 the write out is not needed so the intent is set as
6214 e
->must_finalize
= 1;
6215 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6216 INTENT_IN
, fsym
->attr
.pointer
);
6218 else if (fsym
&& fsym
->attr
.contiguous
6219 && !gfc_is_simply_contiguous (e
, false, true)
6220 && gfc_expr_is_variable (e
))
6222 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6224 fsym
->attr
.pointer
);
6227 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6230 /* Unallocated allocatable arrays and unassociated pointer arrays
6231 need their dtype setting if they are argument associated with
6232 assumed rank dummies. */
6233 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6234 && fsym
->as
->type
== AS_ASSUMED_RANK
)
6236 if (gfc_expr_attr (e
).pointer
6237 || gfc_expr_attr (e
).allocatable
)
6238 set_dtype_for_unallocated (&parmse
, e
);
6239 else if (e
->expr_type
== EXPR_VARIABLE
6240 && e
->symtree
->n
.sym
->attr
.dummy
6241 && e
->symtree
->n
.sym
->as
6242 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
6245 tmp
= build_fold_indirect_ref_loc (input_location
,
6247 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6248 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6249 gfc_rank_cst
[e
->rank
- 1],
6254 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6255 allocated on entry, it must be deallocated. */
6256 if (fsym
&& fsym
->attr
.allocatable
6257 && fsym
->attr
.intent
== INTENT_OUT
)
6259 if (fsym
->ts
.type
== BT_DERIVED
6260 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6262 // deallocate the components first
6263 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6264 parmse
.expr
, e
->rank
);
6265 if (tmp
!= NULL_TREE
)
6266 gfc_add_expr_to_block (&se
->pre
, tmp
);
6270 /* With bind(C), the actual argument is replaced by a bind-C
6271 descriptor; in this case, the data component arrives here,
6272 which shall not be dereferenced, but still freed and
6274 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6275 tmp
= build_fold_indirect_ref_loc (input_location
,
6277 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6278 tmp
= gfc_conv_descriptor_data_get (tmp
);
6279 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6280 NULL_TREE
, NULL_TREE
, true,
6282 GFC_CAF_COARRAY_NOCOARRAY
);
6283 if (fsym
->attr
.optional
6284 && e
->expr_type
== EXPR_VARIABLE
6285 && e
->symtree
->n
.sym
->attr
.optional
)
6286 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6288 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6289 tmp
, build_empty_stmt (input_location
));
6290 gfc_add_expr_to_block (&se
->pre
, tmp
);
6295 /* The case with fsym->attr.optional is that of a user subroutine
6296 with an interface indicating an optional argument. When we call
6297 an intrinsic subroutine, however, fsym is NULL, but we might still
6298 have an optional argument, so we proceed to the substitution
6300 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6302 /* If an optional argument is itself an optional dummy argument,
6303 check its presence and substitute a null if absent. This is
6304 only needed when passing an array to an elemental procedure
6305 as then array elements are accessed - or no NULL pointer is
6306 allowed and a "1" or "0" should be passed if not present.
6307 When passing a non-array-descriptor full array to a
6308 non-array-descriptor dummy, no check is needed. For
6309 array-descriptor actual to array-descriptor dummy, see
6310 PR 41911 for why a check has to be inserted.
6311 fsym == NULL is checked as intrinsics required the descriptor
6312 but do not always set fsym.
6313 Also, it is necessary to pass a NULL pointer to library routines
6314 which usually ignore optional arguments, so they can handle
6315 these themselves. */
6316 if (e
->expr_type
== EXPR_VARIABLE
6317 && e
->symtree
->n
.sym
->attr
.optional
6318 && (((e
->rank
!= 0 && elemental_proc
)
6319 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6323 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6324 || fsym
->as
->type
== AS_ASSUMED_RANK
6325 || fsym
->as
->type
== AS_DEFERRED
)))))
6326 || se
->ignore_optional
))
6327 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6328 e
->representation
.length
);
6333 /* Obtain the character length of an assumed character length
6334 length procedure from the typespec. */
6335 if (fsym
->ts
.type
== BT_CHARACTER
6336 && parmse
.string_length
== NULL_TREE
6337 && e
->ts
.type
== BT_PROCEDURE
6338 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6339 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6340 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6342 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6343 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6347 if (fsym
&& need_interface_mapping
&& e
)
6348 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6350 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6351 gfc_add_block_to_block (&post
, &parmse
.post
);
6353 /* Allocated allocatable components of derived types must be
6354 deallocated for non-variable scalars, array arguments to elemental
6355 procedures, and array arguments with descriptor to non-elemental
6356 procedures. As bounds information for descriptorless arrays is no
6357 longer available here, they are dealt with in trans-array.c
6358 (gfc_conv_array_parameter). */
6359 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
6360 && e
->ts
.u
.derived
->attr
.alloc_comp
6361 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
6362 && !expr_may_alias_variables (e
, elemental_proc
))
6365 /* It is known the e returns a structure type with at least one
6366 allocatable component. When e is a function, ensure that the
6367 function is called once only by using a temporary variable. */
6368 if (!DECL_P (parmse
.expr
))
6369 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
6370 parmse
.expr
, &se
->pre
);
6372 if (fsym
&& fsym
->attr
.value
)
6375 tmp
= build_fold_indirect_ref_loc (input_location
,
6378 parm_rank
= e
->rank
;
6386 case (SCALAR_POINTER
):
6387 tmp
= build_fold_indirect_ref_loc (input_location
,
6392 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
6394 /* The derived type is passed to gfc_deallocate_alloc_comp.
6395 Therefore, class actuals can be handled correctly but derived
6396 types passed to class formals need the _data component. */
6397 tmp
= gfc_class_data_get (tmp
);
6398 if (!CLASS_DATA (fsym
)->attr
.dimension
)
6399 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6402 if (e
->expr_type
== EXPR_OP
6403 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
6404 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
6407 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6408 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
6410 gfc_add_expr_to_block (&se
->post
, local_tmp
);
6413 if (!finalized
&& !e
->must_finalize
)
6415 if ((e
->ts
.type
== BT_CLASS
6416 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
6417 || e
->ts
.type
== BT_DERIVED
)
6418 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6420 else if (e
->ts
.type
== BT_CLASS
)
6421 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6423 gfc_prepend_expr_to_block (&post
, tmp
);
6427 /* Add argument checking of passing an unallocated/NULL actual to
6428 a nonallocatable/nonpointer dummy. */
6430 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6432 symbol_attribute attr
;
6436 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6437 attr
= gfc_expr_attr (e
);
6439 goto end_pointer_check
;
6441 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6442 allocatable to an optional dummy, cf. 12.5.2.12. */
6443 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6444 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6445 goto end_pointer_check
;
6449 /* If the actual argument is an optional pointer/allocatable and
6450 the formal argument takes an nonpointer optional value,
6451 it is invalid to pass a non-present argument on, even
6452 though there is no technical reason for this in gfortran.
6453 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6454 tree present
, null_ptr
, type
;
6456 if (attr
.allocatable
6457 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6458 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6459 "allocated or not present",
6460 e
->symtree
->n
.sym
->name
);
6461 else if (attr
.pointer
6462 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6463 msg
= xasprintf ("Pointer actual argument '%s' is not "
6464 "associated or not present",
6465 e
->symtree
->n
.sym
->name
);
6466 else if (attr
.proc_pointer
6467 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6468 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6469 "associated or not present",
6470 e
->symtree
->n
.sym
->name
);
6472 goto end_pointer_check
;
6474 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6475 type
= TREE_TYPE (present
);
6476 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6477 logical_type_node
, present
,
6479 null_pointer_node
));
6480 type
= TREE_TYPE (parmse
.expr
);
6481 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6482 logical_type_node
, parmse
.expr
,
6484 null_pointer_node
));
6485 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6486 logical_type_node
, present
, null_ptr
);
6490 if (attr
.allocatable
6491 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6492 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6493 "allocated", e
->symtree
->n
.sym
->name
);
6494 else if (attr
.pointer
6495 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6496 msg
= xasprintf ("Pointer actual argument '%s' is not "
6497 "associated", e
->symtree
->n
.sym
->name
);
6498 else if (attr
.proc_pointer
6499 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6500 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6501 "associated", e
->symtree
->n
.sym
->name
);
6503 goto end_pointer_check
;
6507 /* If the argument is passed by value, we need to strip the
6509 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6510 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6512 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6513 logical_type_node
, tmp
,
6514 fold_convert (TREE_TYPE (tmp
),
6515 null_pointer_node
));
6518 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6524 /* Deferred length dummies pass the character length by reference
6525 so that the value can be returned. */
6526 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6528 if (INDIRECT_REF_P (parmse
.string_length
))
6529 /* In chains of functions/procedure calls the string_length already
6530 is a pointer to the variable holding the length. Therefore
6531 remove the deref on call. */
6532 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6535 tmp
= parmse
.string_length
;
6536 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6537 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6538 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6542 /* Character strings are passed as two parameters, a length and a
6543 pointer - except for Bind(c) which only passes the pointer.
6544 An unlimited polymorphic formal argument likewise does not
6546 if (parmse
.string_length
!= NULL_TREE
6547 && !sym
->attr
.is_bind_c
6548 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6549 vec_safe_push (stringargs
, parmse
.string_length
);
6551 /* When calling __copy for character expressions to unlimited
6552 polymorphic entities, the dst argument needs a string length. */
6553 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6554 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6555 && arg
->next
&& arg
->next
->expr
6556 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6557 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6558 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6559 vec_safe_push (stringargs
, parmse
.string_length
);
6561 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6562 pass the token and the offset as additional arguments. */
6563 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6564 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6565 && !fsym
->attr
.allocatable
)
6566 || (fsym
->ts
.type
== BT_CLASS
6567 && CLASS_DATA (fsym
)->attr
.codimension
6568 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6570 /* Token and offset. */
6571 vec_safe_push (stringargs
, null_pointer_node
);
6572 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6573 gcc_assert (fsym
->attr
.optional
);
6575 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6576 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6577 && !fsym
->attr
.allocatable
)
6578 || (fsym
->ts
.type
== BT_CLASS
6579 && CLASS_DATA (fsym
)->attr
.codimension
6580 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6582 tree caf_decl
, caf_type
;
6585 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6586 caf_type
= TREE_TYPE (caf_decl
);
6588 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6589 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6590 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6591 tmp
= gfc_conv_descriptor_token (caf_decl
);
6592 else if (DECL_LANG_SPECIFIC (caf_decl
)
6593 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6594 tmp
= GFC_DECL_TOKEN (caf_decl
);
6597 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6598 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6599 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6602 vec_safe_push (stringargs
, tmp
);
6604 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6605 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6606 offset
= build_int_cst (gfc_array_index_type
, 0);
6607 else if (DECL_LANG_SPECIFIC (caf_decl
)
6608 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6609 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6610 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6611 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6613 offset
= build_int_cst (gfc_array_index_type
, 0);
6615 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6616 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6619 gcc_assert (POINTER_TYPE_P (caf_type
));
6623 tmp2
= fsym
->ts
.type
== BT_CLASS
6624 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6625 if ((fsym
->ts
.type
!= BT_CLASS
6626 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6627 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6628 || (fsym
->ts
.type
== BT_CLASS
6629 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6630 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6632 if (fsym
->ts
.type
== BT_CLASS
)
6633 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6636 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6637 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6639 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6640 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6642 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6643 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6646 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6649 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6650 gfc_array_index_type
,
6651 fold_convert (gfc_array_index_type
, tmp2
),
6652 fold_convert (gfc_array_index_type
, tmp
));
6653 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6654 gfc_array_index_type
, offset
, tmp
);
6656 vec_safe_push (stringargs
, offset
);
6659 vec_safe_push (arglist
, parmse
.expr
);
6661 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6665 else if (sym
->ts
.type
== BT_CLASS
)
6666 ts
= CLASS_DATA (sym
)->ts
;
6670 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6671 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6672 else if (ts
.type
== BT_CHARACTER
)
6674 if (ts
.u
.cl
->length
== NULL
)
6676 /* Assumed character length results are not allowed by C418 of the 2003
6677 standard and are trapped in resolve.c; except in the case of SPREAD
6678 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6679 we take the character length of the first argument for the result.
6680 For dummies, we have to look through the formal argument list for
6681 this function and use the character length found there.*/
6683 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6684 else if (!sym
->attr
.dummy
)
6685 cl
.backend_decl
= (*stringargs
)[0];
6688 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6689 for (; formal
; formal
= formal
->next
)
6690 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6691 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6693 len
= cl
.backend_decl
;
6699 /* Calculate the length of the returned string. */
6700 gfc_init_se (&parmse
, NULL
);
6701 if (need_interface_mapping
)
6702 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6704 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6705 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6706 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6708 /* TODO: It would be better to have the charlens as
6709 gfc_charlen_type_node already when the interface is
6710 created instead of converting it here (see PR 84615). */
6711 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6712 gfc_charlen_type_node
,
6713 fold_convert (gfc_charlen_type_node
, tmp
),
6714 build_zero_cst (gfc_charlen_type_node
));
6715 cl
.backend_decl
= tmp
;
6718 /* Set up a charlen structure for it. */
6723 len
= cl
.backend_decl
;
6726 byref
= (comp
&& (comp
->attr
.dimension
6727 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6728 || (!comp
&& gfc_return_by_reference (sym
));
6731 if (se
->direct_byref
)
6733 /* Sometimes, too much indirection can be applied; e.g. for
6734 function_result = array_valued_recursive_function. */
6735 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6736 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6737 && GFC_DESCRIPTOR_TYPE_P
6738 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6739 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6742 /* If the lhs of an assignment x = f(..) is allocatable and
6743 f2003 is allowed, we must do the automatic reallocation.
6744 TODO - deal with intrinsics, without using a temporary. */
6745 if (flag_realloc_lhs
6746 && se
->ss
&& se
->ss
->loop_chain
6747 && se
->ss
->loop_chain
->is_alloc_lhs
6748 && !expr
->value
.function
.isym
6749 && sym
->result
->as
!= NULL
)
6751 /* Evaluate the bounds of the result, if known. */
6752 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6755 /* Perform the automatic reallocation. */
6756 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6758 gfc_add_expr_to_block (&se
->pre
, tmp
);
6760 /* Pass the temporary as the first argument. */
6761 result
= info
->descriptor
;
6764 result
= build_fold_indirect_ref_loc (input_location
,
6766 vec_safe_push (retargs
, se
->expr
);
6768 else if (comp
&& comp
->attr
.dimension
)
6770 gcc_assert (se
->loop
&& info
);
6772 /* Set the type of the array. */
6773 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6774 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6776 /* Evaluate the bounds of the result, if known. */
6777 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6779 /* If the lhs of an assignment x = f(..) is allocatable and
6780 f2003 is allowed, we must not generate the function call
6781 here but should just send back the results of the mapping.
6782 This is signalled by the function ss being flagged. */
6783 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6785 gfc_free_interface_mapping (&mapping
);
6786 return has_alternate_specifier
;
6789 /* Create a temporary to store the result. In case the function
6790 returns a pointer, the temporary will be a shallow copy and
6791 mustn't be deallocated. */
6792 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6793 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6794 tmp
, NULL_TREE
, false,
6795 !comp
->attr
.pointer
, callee_alloc
,
6796 &se
->ss
->info
->expr
->where
);
6798 /* Pass the temporary as the first argument. */
6799 result
= info
->descriptor
;
6800 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6801 vec_safe_push (retargs
, tmp
);
6803 else if (!comp
&& sym
->result
->attr
.dimension
)
6805 gcc_assert (se
->loop
&& info
);
6807 /* Set the type of the array. */
6808 tmp
= gfc_typenode_for_spec (&ts
);
6809 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6811 /* Evaluate the bounds of the result, if known. */
6812 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6814 /* If the lhs of an assignment x = f(..) is allocatable and
6815 f2003 is allowed, we must not generate the function call
6816 here but should just send back the results of the mapping.
6817 This is signalled by the function ss being flagged. */
6818 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6820 gfc_free_interface_mapping (&mapping
);
6821 return has_alternate_specifier
;
6824 /* Create a temporary to store the result. In case the function
6825 returns a pointer, the temporary will be a shallow copy and
6826 mustn't be deallocated. */
6827 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6828 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6829 tmp
, NULL_TREE
, false,
6830 !sym
->attr
.pointer
, callee_alloc
,
6831 &se
->ss
->info
->expr
->where
);
6833 /* Pass the temporary as the first argument. */
6834 result
= info
->descriptor
;
6835 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6836 vec_safe_push (retargs
, tmp
);
6838 else if (ts
.type
== BT_CHARACTER
)
6840 /* Pass the string length. */
6841 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6842 type
= build_pointer_type (type
);
6844 /* Emit a DECL_EXPR for the VLA type. */
6845 tmp
= TREE_TYPE (type
);
6847 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6849 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6850 DECL_ARTIFICIAL (tmp
) = 1;
6851 DECL_IGNORED_P (tmp
) = 1;
6852 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6853 TREE_TYPE (tmp
), tmp
);
6854 gfc_add_expr_to_block (&se
->pre
, tmp
);
6857 /* Return an address to a char[0:len-1]* temporary for
6858 character pointers. */
6859 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6860 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6862 var
= gfc_create_var (type
, "pstr");
6864 if ((!comp
&& sym
->attr
.allocatable
)
6865 || (comp
&& comp
->attr
.allocatable
))
6867 gfc_add_modify (&se
->pre
, var
,
6868 fold_convert (TREE_TYPE (var
),
6869 null_pointer_node
));
6870 tmp
= gfc_call_free (var
);
6871 gfc_add_expr_to_block (&se
->post
, tmp
);
6874 /* Provide an address expression for the function arguments. */
6875 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6878 var
= gfc_conv_string_tmp (se
, type
, len
);
6880 vec_safe_push (retargs
, var
);
6884 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6886 type
= gfc_get_complex_type (ts
.kind
);
6887 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6888 vec_safe_push (retargs
, var
);
6891 /* Add the string length to the argument list. */
6892 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6896 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6897 TREE_STATIC (tmp
) = 1;
6898 gfc_add_modify (&se
->pre
, tmp
,
6899 build_int_cst (TREE_TYPE (tmp
), 0));
6900 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6901 vec_safe_push (retargs
, tmp
);
6903 else if (ts
.type
== BT_CHARACTER
)
6904 vec_safe_push (retargs
, len
);
6906 gfc_free_interface_mapping (&mapping
);
6908 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6909 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6910 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6911 vec_safe_reserve (retargs
, arglen
);
6913 /* Add the return arguments. */
6914 vec_safe_splice (retargs
, arglist
);
6916 /* Add the hidden present status for optional+value to the arguments. */
6917 vec_safe_splice (retargs
, optionalargs
);
6919 /* Add the hidden string length parameters to the arguments. */
6920 vec_safe_splice (retargs
, stringargs
);
6922 /* We may want to append extra arguments here. This is used e.g. for
6923 calls to libgfortran_matmul_??, which need extra information. */
6924 vec_safe_splice (retargs
, append_args
);
6928 /* Generate the actual call. */
6929 if (base_object
== NULL_TREE
)
6930 conv_function_val (se
, sym
, expr
, args
);
6932 conv_base_obj_fcn_val (se
, base_object
, expr
);
6934 /* If there are alternate return labels, function type should be
6935 integer. Can't modify the type in place though, since it can be shared
6936 with other functions. For dummy arguments, the typing is done to
6937 this result, even if it has to be repeated for each call. */
6938 if (has_alternate_specifier
6939 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6941 if (!sym
->attr
.dummy
)
6943 TREE_TYPE (sym
->backend_decl
)
6944 = build_function_type (integer_type_node
,
6945 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6946 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6949 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6952 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6953 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6955 /* Allocatable scalar function results must be freed and nullified
6956 after use. This necessitates the creation of a temporary to
6957 hold the result to prevent duplicate calls. */
6958 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6959 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6960 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6962 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6963 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6965 tmp
= gfc_call_free (tmp
);
6966 gfc_add_expr_to_block (&post
, tmp
);
6967 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6970 /* If we have a pointer function, but we don't want a pointer, e.g.
6973 where f is pointer valued, we have to dereference the result. */
6974 if (!se
->want_pointer
&& !byref
6975 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6976 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6977 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6979 /* f2c calling conventions require a scalar default real function to
6980 return a double precision result. Convert this back to default
6981 real. We only care about the cases that can happen in Fortran 77.
6983 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6984 && sym
->ts
.kind
== gfc_default_real_kind
6985 && !sym
->attr
.always_explicit
)
6986 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6988 /* A pure function may still have side-effects - it may modify its
6990 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6992 if (!sym
->attr
.pure
)
6993 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6998 /* Add the function call to the pre chain. There is no expression. */
6999 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
7000 se
->expr
= NULL_TREE
;
7002 if (!se
->direct_byref
)
7004 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
7006 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
7008 /* Check the data pointer hasn't been modified. This would
7009 happen in a function returning a pointer. */
7010 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7011 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7014 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7017 se
->expr
= info
->descriptor
;
7018 /* Bundle in the string length. */
7019 se
->string_length
= len
;
7021 else if (ts
.type
== BT_CHARACTER
)
7023 /* Dereference for character pointer results. */
7024 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7025 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7026 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7030 se
->string_length
= len
;
7034 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7035 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7040 /* Associate the rhs class object's meta-data with the result, when the
7041 result is a temporary. */
7042 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7043 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7044 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7047 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7049 gfc_init_se (&parmse
, NULL
);
7050 parmse
.data_not_needed
= 1;
7051 gfc_conv_expr (&parmse
, class_expr
);
7052 if (!DECL_LANG_SPECIFIC (result
))
7053 gfc_allocate_lang_decl (result
);
7054 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7055 gfc_free_expr (class_expr
);
7056 /* -fcheck= can add diagnostic code, which has to be placed before
7058 if (parmse
.pre
.head
!= NULL
)
7059 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7060 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7063 /* Follow the function call with the argument post block. */
7066 gfc_add_block_to_block (&se
->pre
, &post
);
7068 /* Transformational functions of derived types with allocatable
7069 components must have the result allocatable components copied when the
7070 argument is actually given. */
7071 arg
= expr
->value
.function
.actual
;
7072 if (result
&& arg
&& expr
->rank
7073 && expr
->value
.function
.isym
7074 && expr
->value
.function
.isym
->transformational
7076 && arg
->expr
->ts
.type
== BT_DERIVED
7077 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7080 /* Copy the allocatable components. We have to use a
7081 temporary here to prevent source allocatable components
7082 from being corrupted. */
7083 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7084 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7085 result
, tmp2
, expr
->rank
, 0);
7086 gfc_add_expr_to_block (&se
->pre
, tmp
);
7087 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7089 gfc_add_expr_to_block (&se
->pre
, tmp
);
7091 /* Finally free the temporary's data field. */
7092 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7093 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7094 NULL_TREE
, NULL_TREE
, true,
7095 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7096 gfc_add_expr_to_block (&se
->pre
, tmp
);
7101 /* For a function with a class array result, save the result as
7102 a temporary, set the info fields needed by the scalarizer and
7103 call the finalization function of the temporary. Note that the
7104 nullification of allocatable components needed by the result
7105 is done in gfc_trans_assignment_1. */
7106 if (expr
&& ((gfc_is_class_array_function (expr
)
7107 && se
->ss
&& se
->ss
->loop
)
7108 || gfc_is_alloc_class_scalar_function (expr
))
7109 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7110 && expr
->must_finalize
)
7115 if (se
->ss
&& se
->ss
->loop
)
7117 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7118 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7119 tmp
= gfc_class_data_get (se
->expr
);
7120 info
->descriptor
= tmp
;
7121 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7122 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7123 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7125 tree dim
= gfc_rank_cst
[n
];
7126 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7127 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7132 /* TODO Eliminate the doubling of temporaries. This
7133 one is necessary to ensure no memory leakage. */
7134 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7135 tmp
= gfc_class_data_get (se
->expr
);
7136 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7137 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7140 if ((gfc_is_class_array_function (expr
)
7141 || gfc_is_alloc_class_scalar_function (expr
))
7142 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7143 goto no_finalization
;
7145 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7146 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7149 fold_convert (TREE_TYPE (final_fndecl
),
7150 null_pointer_node
));
7151 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7153 tmp
= build_call_expr_loc (input_location
,
7155 gfc_build_addr_expr (NULL
, tmp
),
7156 gfc_class_vtab_size_get (se
->expr
),
7157 boolean_false_node
);
7158 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7159 void_type_node
, is_final
, tmp
,
7160 build_empty_stmt (input_location
));
7162 if (se
->ss
&& se
->ss
->loop
)
7164 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7165 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7168 fold_convert (TREE_TYPE (info
->data
),
7169 null_pointer_node
));
7170 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7171 void_type_node
, tmp
,
7172 gfc_call_free (info
->data
),
7173 build_empty_stmt (input_location
));
7174 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7179 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7180 classdata
= gfc_class_data_get (se
->expr
);
7181 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7184 fold_convert (TREE_TYPE (classdata
),
7185 null_pointer_node
));
7186 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7187 void_type_node
, tmp
,
7188 gfc_call_free (classdata
),
7189 build_empty_stmt (input_location
));
7190 gfc_add_expr_to_block (&se
->post
, tmp
);
7195 gfc_add_block_to_block (&se
->post
, &post
);
7198 return has_alternate_specifier
;
7202 /* Fill a character string with spaces. */
7205 fill_with_spaces (tree start
, tree type
, tree size
)
7207 stmtblock_t block
, loop
;
7208 tree i
, el
, exit_label
, cond
, tmp
;
7210 /* For a simple char type, we can call memset(). */
7211 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7212 return build_call_expr_loc (input_location
,
7213 builtin_decl_explicit (BUILT_IN_MEMSET
),
7215 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7216 lang_hooks
.to_target_charset (' ')),
7217 fold_convert (size_type_node
, size
));
7219 /* Otherwise, we use a loop:
7220 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7224 /* Initialize variables. */
7225 gfc_init_block (&block
);
7226 i
= gfc_create_var (sizetype
, "i");
7227 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7228 el
= gfc_create_var (build_pointer_type (type
), "el");
7229 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7230 exit_label
= gfc_build_label_decl (NULL_TREE
);
7231 TREE_USED (exit_label
) = 1;
7235 gfc_init_block (&loop
);
7237 /* Exit condition. */
7238 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7239 build_zero_cst (sizetype
));
7240 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7241 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7242 build_empty_stmt (input_location
));
7243 gfc_add_expr_to_block (&loop
, tmp
);
7246 gfc_add_modify (&loop
,
7247 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7248 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7250 /* Increment loop variables. */
7251 gfc_add_modify (&loop
, i
,
7252 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7253 TYPE_SIZE_UNIT (type
)));
7254 gfc_add_modify (&loop
, el
,
7255 fold_build_pointer_plus_loc (input_location
,
7256 el
, TYPE_SIZE_UNIT (type
)));
7258 /* Making the loop... actually loop! */
7259 tmp
= gfc_finish_block (&loop
);
7260 tmp
= build1_v (LOOP_EXPR
, tmp
);
7261 gfc_add_expr_to_block (&block
, tmp
);
7263 /* The exit label. */
7264 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7265 gfc_add_expr_to_block (&block
, tmp
);
7268 return gfc_finish_block (&block
);
7272 /* Generate code to copy a string. */
7275 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7276 int dkind
, tree slength
, tree src
, int skind
)
7278 tree tmp
, dlen
, slen
;
7287 stmtblock_t tempblock
;
7289 gcc_assert (dkind
== skind
);
7291 if (slength
!= NULL_TREE
)
7293 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7294 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
7298 slen
= build_one_cst (gfc_charlen_type_node
);
7302 if (dlength
!= NULL_TREE
)
7304 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
7305 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
7309 dlen
= build_one_cst (gfc_charlen_type_node
);
7313 /* Assign directly if the types are compatible. */
7314 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
7315 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
7317 gfc_add_modify (block
, dsc
, ssc
);
7321 /* The string copy algorithm below generates code like
7325 if (srclen < destlen)
7327 memmove (dest, src, srclen);
7329 memset (&dest[srclen], ' ', destlen - srclen);
7333 // Truncate if too long.
7334 memmove (dest, src, destlen);
7339 /* Do nothing if the destination length is zero. */
7340 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
7341 build_zero_cst (TREE_TYPE (dlen
)));
7343 /* For non-default character kinds, we have to multiply the string
7344 length by the base type size. */
7345 chartype
= gfc_get_char_type (dkind
);
7346 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
7348 fold_convert (TREE_TYPE (slen
),
7349 TYPE_SIZE_UNIT (chartype
)));
7350 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
7352 fold_convert (TREE_TYPE (dlen
),
7353 TYPE_SIZE_UNIT (chartype
)));
7355 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
7356 dest
= fold_convert (pvoid_type_node
, dest
);
7358 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
7360 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
7361 src
= fold_convert (pvoid_type_node
, src
);
7363 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7365 /* Truncate string if source is too long. */
7366 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
7369 /* Copy and pad with spaces. */
7370 tmp3
= build_call_expr_loc (input_location
,
7371 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7373 fold_convert (size_type_node
, slen
));
7375 /* Wstringop-overflow appears at -O3 even though this warning is not
7376 explicitly available in fortran nor can it be switched off. If the
7377 source length is a constant, its negative appears as a very large
7378 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7379 the result of the MINUS_EXPR suppresses this spurious warning. */
7380 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7381 TREE_TYPE(dlen
), dlen
, slen
);
7382 if (slength
&& TREE_CONSTANT (slength
))
7383 tmp
= gfc_evaluate_now (tmp
, block
);
7385 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
7386 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
7388 gfc_init_block (&tempblock
);
7389 gfc_add_expr_to_block (&tempblock
, tmp3
);
7390 gfc_add_expr_to_block (&tempblock
, tmp4
);
7391 tmp3
= gfc_finish_block (&tempblock
);
7393 /* The truncated memmove if the slen >= dlen. */
7394 tmp2
= build_call_expr_loc (input_location
,
7395 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7397 fold_convert (size_type_node
, dlen
));
7399 /* The whole copy_string function is there. */
7400 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
7402 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7403 build_empty_stmt (input_location
));
7404 gfc_add_expr_to_block (block
, tmp
);
7408 /* Translate a statement function.
7409 The value of a statement function reference is obtained by evaluating the
7410 expression using the values of the actual arguments for the values of the
7411 corresponding dummy arguments. */
7414 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
7418 gfc_formal_arglist
*fargs
;
7419 gfc_actual_arglist
*args
;
7422 gfc_saved_var
*saved_vars
;
7428 sym
= expr
->symtree
->n
.sym
;
7429 args
= expr
->value
.function
.actual
;
7430 gfc_init_se (&lse
, NULL
);
7431 gfc_init_se (&rse
, NULL
);
7434 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7436 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7437 temp_vars
= XCNEWVEC (tree
, n
);
7439 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7440 fargs
= fargs
->next
, n
++)
7442 /* Each dummy shall be specified, explicitly or implicitly, to be
7444 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7447 if (fsym
->ts
.type
== BT_CHARACTER
)
7449 /* Copy string arguments. */
7452 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7453 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7455 /* Create a temporary to hold the value. */
7456 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7457 fsym
->ts
.u
.cl
->backend_decl
7458 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7460 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7461 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7463 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7465 gfc_conv_expr (&rse
, args
->expr
);
7466 gfc_conv_string_parameter (&rse
);
7467 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7468 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7470 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7471 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7472 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7473 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7477 /* For everything else, just evaluate the expression. */
7479 /* Create a temporary to hold the value. */
7480 type
= gfc_typenode_for_spec (&fsym
->ts
);
7481 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7483 gfc_conv_expr (&lse
, args
->expr
);
7485 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7486 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7487 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7493 /* Use the temporary variables in place of the real ones. */
7494 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7495 fargs
= fargs
->next
, n
++)
7496 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7498 gfc_conv_expr (se
, sym
->value
);
7500 if (sym
->ts
.type
== BT_CHARACTER
)
7502 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7504 /* Force the expression to the correct length. */
7505 if (!INTEGER_CST_P (se
->string_length
)
7506 || tree_int_cst_lt (se
->string_length
,
7507 sym
->ts
.u
.cl
->backend_decl
))
7509 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7510 tmp
= gfc_create_var (type
, sym
->name
);
7511 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7512 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7513 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7517 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7520 /* Restore the original variables. */
7521 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7522 fargs
= fargs
->next
, n
++)
7523 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7529 /* Translate a function expression. */
7532 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7536 if (expr
->value
.function
.isym
)
7538 gfc_conv_intrinsic_function (se
, expr
);
7542 /* expr.value.function.esym is the resolved (specific) function symbol for
7543 most functions. However this isn't set for dummy procedures. */
7544 sym
= expr
->value
.function
.esym
;
7546 sym
= expr
->symtree
->n
.sym
;
7548 /* The IEEE_ARITHMETIC functions are caught here. */
7549 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7550 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7553 /* We distinguish statement functions from general functions to improve
7554 runtime performance. */
7555 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7557 gfc_conv_statement_function (se
, expr
);
7561 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7566 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7569 is_zero_initializer_p (gfc_expr
* expr
)
7571 if (expr
->expr_type
!= EXPR_CONSTANT
)
7574 /* We ignore constants with prescribed memory representations for now. */
7575 if (expr
->representation
.string
)
7578 switch (expr
->ts
.type
)
7581 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7584 return mpfr_zero_p (expr
->value
.real
)
7585 && MPFR_SIGN (expr
->value
.real
) >= 0;
7588 return expr
->value
.logical
== 0;
7591 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7592 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7593 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7594 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7604 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7609 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7610 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7612 gfc_conv_tmp_array_ref (se
);
7616 /* Build a static initializer. EXPR is the expression for the initial value.
7617 The other parameters describe the variable of the component being
7618 initialized. EXPR may be null. */
7621 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7622 bool array
, bool pointer
, bool procptr
)
7626 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7627 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7628 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7629 return build_constructor (type
, NULL
);
7631 if (!(expr
|| pointer
|| procptr
))
7634 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7635 (these are the only two iso_c_binding derived types that can be
7636 used as initialization expressions). If so, we need to modify
7637 the 'expr' to be that for a (void *). */
7638 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7639 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7641 if (TREE_CODE (type
) == ARRAY_TYPE
)
7642 return build_constructor (type
, NULL
);
7643 else if (POINTER_TYPE_P (type
))
7644 return build_int_cst (type
, 0);
7649 if (array
&& !procptr
)
7652 /* Arrays need special handling. */
7654 ctor
= gfc_build_null_descriptor (type
);
7655 /* Special case assigning an array to zero. */
7656 else if (is_zero_initializer_p (expr
))
7657 ctor
= build_constructor (type
, NULL
);
7659 ctor
= gfc_conv_array_initializer (type
, expr
);
7660 TREE_STATIC (ctor
) = 1;
7663 else if (pointer
|| procptr
)
7665 if (ts
->type
== BT_CLASS
&& !procptr
)
7667 gfc_init_se (&se
, NULL
);
7668 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7669 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7670 TREE_STATIC (se
.expr
) = 1;
7673 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7674 return fold_convert (type
, null_pointer_node
);
7677 gfc_init_se (&se
, NULL
);
7678 se
.want_pointer
= 1;
7679 gfc_conv_expr (&se
, expr
);
7680 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7690 gfc_init_se (&se
, NULL
);
7691 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7692 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7694 gfc_conv_structure (&se
, expr
, 1);
7695 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7696 TREE_STATIC (se
.expr
) = 1;
7701 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
7702 TREE_STATIC (ctor
) = 1;
7707 gfc_init_se (&se
, NULL
);
7708 gfc_conv_constant (&se
, expr
);
7709 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7716 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7722 gfc_array_info
*lss_array
;
7729 gfc_start_block (&block
);
7731 /* Initialize the scalarizer. */
7732 gfc_init_loopinfo (&loop
);
7734 gfc_init_se (&lse
, NULL
);
7735 gfc_init_se (&rse
, NULL
);
7738 rss
= gfc_walk_expr (expr
);
7739 if (rss
== gfc_ss_terminator
)
7740 /* The rhs is scalar. Add a ss for the expression. */
7741 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7743 /* Create a SS for the destination. */
7744 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7746 lss_array
= &lss
->info
->data
.array
;
7747 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7748 lss_array
->descriptor
= dest
;
7749 lss_array
->data
= gfc_conv_array_data (dest
);
7750 lss_array
->offset
= gfc_conv_array_offset (dest
);
7751 for (n
= 0; n
< cm
->as
->rank
; n
++)
7753 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7754 lss_array
->stride
[n
] = gfc_index_one_node
;
7756 mpz_init (lss_array
->shape
[n
]);
7757 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7758 cm
->as
->lower
[n
]->value
.integer
);
7759 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7762 /* Associate the SS with the loop. */
7763 gfc_add_ss_to_loop (&loop
, lss
);
7764 gfc_add_ss_to_loop (&loop
, rss
);
7766 /* Calculate the bounds of the scalarization. */
7767 gfc_conv_ss_startstride (&loop
);
7769 /* Setup the scalarizing loops. */
7770 gfc_conv_loop_setup (&loop
, &expr
->where
);
7772 /* Setup the gfc_se structures. */
7773 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7774 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7777 gfc_mark_ss_chain_used (rss
, 1);
7779 gfc_mark_ss_chain_used (lss
, 1);
7781 /* Start the scalarized loop body. */
7782 gfc_start_scalarized_body (&loop
, &body
);
7784 gfc_conv_tmp_array_ref (&lse
);
7785 if (cm
->ts
.type
== BT_CHARACTER
)
7786 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7788 gfc_conv_expr (&rse
, expr
);
7790 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7791 gfc_add_expr_to_block (&body
, tmp
);
7793 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7795 /* Generate the copying loops. */
7796 gfc_trans_scalarizing_loops (&loop
, &body
);
7798 /* Wrap the whole thing up. */
7799 gfc_add_block_to_block (&block
, &loop
.pre
);
7800 gfc_add_block_to_block (&block
, &loop
.post
);
7802 gcc_assert (lss_array
->shape
!= NULL
);
7803 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7804 gfc_cleanup_loop (&loop
);
7806 return gfc_finish_block (&block
);
7811 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7821 gfc_expr
*arg
= NULL
;
7823 gfc_start_block (&block
);
7824 gfc_init_se (&se
, NULL
);
7826 /* Get the descriptor for the expressions. */
7827 se
.want_pointer
= 0;
7828 gfc_conv_expr_descriptor (&se
, expr
);
7829 gfc_add_block_to_block (&block
, &se
.pre
);
7830 gfc_add_modify (&block
, dest
, se
.expr
);
7832 /* Deal with arrays of derived types with allocatable components. */
7833 if (gfc_bt_struct (cm
->ts
.type
)
7834 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7835 // TODO: Fix caf_mode
7836 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7839 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7840 && CLASS_DATA(cm
)->attr
.allocatable
)
7842 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7843 // TODO: Fix caf_mode
7844 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7849 tmp
= TREE_TYPE (dest
);
7850 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7851 tmp
, expr
->rank
, NULL_TREE
);
7855 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7856 TREE_TYPE(cm
->backend_decl
),
7857 cm
->as
->rank
, NULL_TREE
);
7859 gfc_add_expr_to_block (&block
, tmp
);
7860 gfc_add_block_to_block (&block
, &se
.post
);
7862 if (expr
->expr_type
!= EXPR_VARIABLE
)
7863 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7866 /* We need to know if the argument of a conversion function is a
7867 variable, so that the correct lower bound can be used. */
7868 if (expr
->expr_type
== EXPR_FUNCTION
7869 && expr
->value
.function
.isym
7870 && expr
->value
.function
.isym
->conversion
7871 && expr
->value
.function
.actual
->expr
7872 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7873 arg
= expr
->value
.function
.actual
->expr
;
7875 /* Obtain the array spec of full array references. */
7877 as
= gfc_get_full_arrayspec_from_expr (arg
);
7879 as
= gfc_get_full_arrayspec_from_expr (expr
);
7881 /* Shift the lbound and ubound of temporaries to being unity,
7882 rather than zero, based. Always calculate the offset. */
7883 offset
= gfc_conv_descriptor_offset_get (dest
);
7884 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7885 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7887 for (n
= 0; n
< expr
->rank
; n
++)
7892 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7893 TODO It looks as if gfc_conv_expr_descriptor should return
7894 the correct bounds and that the following should not be
7895 necessary. This would simplify gfc_conv_intrinsic_bound
7897 if (as
&& as
->lower
[n
])
7900 gfc_init_se (&lbse
, NULL
);
7901 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7902 gfc_add_block_to_block (&block
, &lbse
.pre
);
7903 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7907 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7908 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7912 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7915 lbound
= gfc_index_one_node
;
7917 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7919 /* Shift the bounds and set the offset accordingly. */
7920 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7921 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7922 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7923 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7925 gfc_conv_descriptor_ubound_set (&block
, dest
,
7926 gfc_rank_cst
[n
], tmp
);
7927 gfc_conv_descriptor_lbound_set (&block
, dest
,
7928 gfc_rank_cst
[n
], lbound
);
7930 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7931 gfc_conv_descriptor_lbound_get (dest
,
7933 gfc_conv_descriptor_stride_get (dest
,
7935 gfc_add_modify (&block
, tmp2
, tmp
);
7936 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7938 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7943 /* If a conversion expression has a null data pointer
7944 argument, nullify the allocatable component. */
7948 if (arg
->symtree
->n
.sym
->attr
.allocatable
7949 || arg
->symtree
->n
.sym
->attr
.pointer
)
7951 non_null_expr
= gfc_finish_block (&block
);
7952 gfc_start_block (&block
);
7953 gfc_conv_descriptor_data_set (&block
, dest
,
7955 null_expr
= gfc_finish_block (&block
);
7956 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7957 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7958 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7959 return build3_v (COND_EXPR
, tmp
,
7960 null_expr
, non_null_expr
);
7964 return gfc_finish_block (&block
);
7968 /* Allocate or reallocate scalar component, as necessary. */
7971 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7981 tree lhs_cl_size
= NULL_TREE
;
7986 if (!expr2
|| expr2
->rank
)
7989 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7991 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7993 char name
[GFC_MAX_SYMBOL_LEN
+9];
7994 gfc_component
*strlen
;
7995 /* Use the rhs string length and the lhs element size. */
7996 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7997 if (!expr2
->ts
.u
.cl
->backend_decl
)
7999 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
8000 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
8003 size
= expr2
->ts
.u
.cl
->backend_decl
;
8005 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8007 sprintf (name
, "_%s_length", cm
->name
);
8008 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
8009 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
8010 gfc_charlen_type_node
,
8011 TREE_OPERAND (comp
, 0),
8012 strlen
->backend_decl
, NULL_TREE
);
8014 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8015 tmp
= TYPE_SIZE_UNIT (tmp
);
8016 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8017 TREE_TYPE (tmp
), tmp
,
8018 fold_convert (TREE_TYPE (tmp
), size
));
8020 else if (cm
->ts
.type
== BT_CLASS
)
8022 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8023 if (expr2
->ts
.type
== BT_DERIVED
)
8025 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8026 size
= TYPE_SIZE_UNIT (tmp
);
8032 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8033 gfc_add_vptr_component (e2vtab
);
8034 gfc_add_size_component (e2vtab
);
8035 gfc_init_se (&se
, NULL
);
8036 gfc_conv_expr (&se
, e2vtab
);
8037 gfc_add_block_to_block (block
, &se
.pre
);
8038 size
= fold_convert (size_type_node
, se
.expr
);
8039 gfc_free_expr (e2vtab
);
8041 size_in_bytes
= size
;
8045 /* Otherwise use the length in bytes of the rhs. */
8046 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8047 size_in_bytes
= size
;
8050 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8051 size_in_bytes
, size_one_node
);
8053 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8055 tmp
= build_call_expr_loc (input_location
,
8056 builtin_decl_explicit (BUILT_IN_CALLOC
),
8057 2, build_one_cst (size_type_node
),
8059 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8060 gfc_add_modify (block
, comp
, tmp
);
8064 tmp
= build_call_expr_loc (input_location
,
8065 builtin_decl_explicit (BUILT_IN_MALLOC
),
8067 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8068 ptr
= gfc_class_data_get (comp
);
8071 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8072 gfc_add_modify (block
, ptr
, tmp
);
8075 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8076 /* Update the lhs character length. */
8077 gfc_add_modify (block
, lhs_cl_size
,
8078 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8082 /* Assign a single component of a derived type constructor. */
8085 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8086 gfc_symbol
*sym
, bool init
)
8094 gfc_start_block (&block
);
8096 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8098 /* Only care about pointers here, not about allocatables. */
8099 gfc_init_se (&se
, NULL
);
8100 /* Pointer component. */
8101 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8102 && !cm
->attr
.proc_pointer
)
8104 /* Array pointer. */
8105 if (expr
->expr_type
== EXPR_NULL
)
8106 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8109 se
.direct_byref
= 1;
8111 gfc_conv_expr_descriptor (&se
, expr
);
8112 gfc_add_block_to_block (&block
, &se
.pre
);
8113 gfc_add_block_to_block (&block
, &se
.post
);
8118 /* Scalar pointers. */
8119 se
.want_pointer
= 1;
8120 gfc_conv_expr (&se
, expr
);
8121 gfc_add_block_to_block (&block
, &se
.pre
);
8123 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8124 && expr
->symtree
->n
.sym
->attr
.dummy
)
8125 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8127 gfc_add_modify (&block
, dest
,
8128 fold_convert (TREE_TYPE (dest
), se
.expr
));
8129 gfc_add_block_to_block (&block
, &se
.post
);
8132 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8134 /* NULL initialization for CLASS components. */
8135 tmp
= gfc_trans_structure_assign (dest
,
8136 gfc_class_initializer (&cm
->ts
, expr
),
8138 gfc_add_expr_to_block (&block
, tmp
);
8140 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8141 && !cm
->attr
.proc_pointer
)
8143 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8144 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8145 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8147 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8148 gfc_add_expr_to_block (&block
, tmp
);
8152 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8153 gfc_add_expr_to_block (&block
, tmp
);
8156 else if (cm
->ts
.type
== BT_CLASS
8157 && CLASS_DATA (cm
)->attr
.dimension
8158 && CLASS_DATA (cm
)->attr
.allocatable
8159 && expr
->ts
.type
== BT_DERIVED
)
8161 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8162 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8163 tmp
= gfc_class_vptr_get (dest
);
8164 gfc_add_modify (&block
, tmp
,
8165 fold_convert (TREE_TYPE (tmp
), vtab
));
8166 tmp
= gfc_class_data_get (dest
);
8167 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8168 gfc_add_expr_to_block (&block
, tmp
);
8170 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8172 /* NULL initialization for allocatable components. */
8173 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8174 null_pointer_node
));
8176 else if (init
&& (cm
->attr
.allocatable
8177 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8178 && expr
->ts
.type
!= BT_CLASS
)))
8180 /* Take care about non-array allocatable components here. The alloc_*
8181 routine below is motivated by the alloc_scalar_allocatable_for_
8182 assignment() routine, but with the realloc portions removed and
8184 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8189 /* The remainder of these instructions follow the if (cm->attr.pointer)
8190 if (!cm->attr.dimension) part above. */
8191 gfc_init_se (&se
, NULL
);
8192 gfc_conv_expr (&se
, expr
);
8193 gfc_add_block_to_block (&block
, &se
.pre
);
8195 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8196 && expr
->symtree
->n
.sym
->attr
.dummy
)
8197 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8199 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8201 tmp
= gfc_class_data_get (dest
);
8202 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8203 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8204 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8205 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8206 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8209 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8211 /* For deferred strings insert a memcpy. */
8212 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8215 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8216 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8218 : expr
->ts
.u
.cl
->backend_decl
);
8219 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8220 gfc_add_expr_to_block (&block
, tmp
);
8223 gfc_add_modify (&block
, tmp
,
8224 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8225 gfc_add_block_to_block (&block
, &se
.post
);
8227 else if (expr
->ts
.type
== BT_UNION
)
8230 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8231 /* We mark that the entire union should be initialized with a contrived
8232 EXPR_NULL expression at the beginning. */
8233 if (c
!= NULL
&& c
->n
.component
== NULL
8234 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8236 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8237 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8238 gfc_add_expr_to_block (&block
, tmp
);
8239 c
= gfc_constructor_next (c
);
8241 /* The following constructor expression, if any, represents a specific
8242 map intializer, as given by the user. */
8243 if (c
!= NULL
&& c
->expr
!= NULL
)
8245 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8246 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8247 gfc_add_expr_to_block (&block
, tmp
);
8250 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8252 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8254 tree dealloc
= NULL_TREE
;
8255 gfc_init_se (&se
, NULL
);
8256 gfc_conv_expr (&se
, expr
);
8257 gfc_add_block_to_block (&block
, &se
.pre
);
8258 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8259 expression in a temporary variable and deallocate the allocatable
8260 components. Then we can the copy the expression to the result. */
8261 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8262 && expr
->expr_type
!= EXPR_VARIABLE
)
8264 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8265 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8268 gfc_add_modify (&block
, dest
,
8269 fold_convert (TREE_TYPE (dest
), se
.expr
));
8270 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8271 && expr
->expr_type
!= EXPR_NULL
)
8273 // TODO: Fix caf_mode
8274 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8275 dest
, expr
->rank
, 0);
8276 gfc_add_expr_to_block (&block
, tmp
);
8277 if (dealloc
!= NULL_TREE
)
8278 gfc_add_expr_to_block (&block
, dealloc
);
8280 gfc_add_block_to_block (&block
, &se
.post
);
8284 /* Nested constructors. */
8285 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8286 gfc_add_expr_to_block (&block
, tmp
);
8289 else if (gfc_deferred_strlen (cm
, &tmp
))
8293 gcc_assert (strlen
);
8294 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8296 TREE_OPERAND (dest
, 0),
8299 if (expr
->expr_type
== EXPR_NULL
)
8301 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
8302 gfc_add_modify (&block
, dest
, tmp
);
8303 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
8304 gfc_add_modify (&block
, strlen
, tmp
);
8309 gfc_init_se (&se
, NULL
);
8310 gfc_conv_expr (&se
, expr
);
8311 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
8312 tmp
= build_call_expr_loc (input_location
,
8313 builtin_decl_explicit (BUILT_IN_MALLOC
),
8315 gfc_add_modify (&block
, dest
,
8316 fold_convert (TREE_TYPE (dest
), tmp
));
8317 gfc_add_modify (&block
, strlen
,
8318 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
8319 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
8320 gfc_add_expr_to_block (&block
, tmp
);
8323 else if (!cm
->attr
.artificial
)
8325 /* Scalar component (excluding deferred parameters). */
8326 gfc_init_se (&se
, NULL
);
8327 gfc_init_se (&lse
, NULL
);
8329 gfc_conv_expr (&se
, expr
);
8330 if (cm
->ts
.type
== BT_CHARACTER
)
8331 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8333 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
8334 gfc_add_expr_to_block (&block
, tmp
);
8336 return gfc_finish_block (&block
);
8339 /* Assign a derived type constructor to a variable. */
8342 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
8351 gfc_start_block (&block
);
8353 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
8354 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
8355 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
8359 gfc_init_se (&se
, NULL
);
8360 gfc_init_se (&lse
, NULL
);
8361 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
8363 gfc_add_modify (&block
, lse
.expr
,
8364 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
8366 return gfc_finish_block (&block
);
8369 /* Make sure that the derived type has been completely built. */
8370 if (!expr
->ts
.u
.derived
->backend_decl
8371 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
8373 tmp
= gfc_typenode_for_spec (&expr
->ts
);
8377 cm
= expr
->ts
.u
.derived
->components
;
8381 gfc_init_se (&se
, NULL
);
8383 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8384 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8386 /* Skip absent members in default initializers. */
8387 if (!c
->expr
&& !cm
->attr
.allocatable
)
8390 /* Register the component with the caf-lib before it is initialized.
8391 Register only allocatable components, that are not coarray'ed
8392 components (%comp[*]). Only register when the constructor is not the
8394 if (coarray
&& !cm
->attr
.codimension
8395 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
8396 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
8398 tree token
, desc
, size
;
8399 bool is_array
= cm
->ts
.type
== BT_CLASS
8400 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
8402 field
= cm
->backend_decl
;
8403 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
8404 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
8405 if (cm
->ts
.type
== BT_CLASS
)
8406 field
= gfc_class_data_get (field
);
8408 token
= is_array
? gfc_conv_descriptor_token (field
)
8409 : fold_build3_loc (input_location
, COMPONENT_REF
,
8410 TREE_TYPE (cm
->caf_token
), dest
,
8411 cm
->caf_token
, NULL_TREE
);
8415 /* The _caf_register routine looks at the rank of the array
8416 descriptor to decide whether the data registered is an array
8418 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
8420 /* When the rank is not known just set a positive rank, which
8421 suffices to recognize the data as array. */
8424 size
= build_zero_cst (size_type_node
);
8426 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
8427 build_int_cst (signed_char_type_node
, rank
));
8431 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8432 cm
->ts
.type
== BT_CLASS
8433 ? CLASS_DATA (cm
)->attr
8435 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8437 gfc_add_block_to_block (&block
, &se
.pre
);
8438 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8439 7, size
, build_int_cst (
8441 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8442 gfc_build_addr_expr (pvoid_type_node
,
8444 gfc_build_addr_expr (NULL_TREE
, desc
),
8445 null_pointer_node
, null_pointer_node
,
8447 gfc_add_expr_to_block (&block
, tmp
);
8449 field
= cm
->backend_decl
;
8451 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8452 dest
, field
, NULL_TREE
);
8455 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8456 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8461 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8462 expr
->ts
.u
.derived
, init
);
8463 gfc_add_expr_to_block (&block
, tmp
);
8465 return gfc_finish_block (&block
);
8469 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8470 gfc_component
*un
, gfc_expr
*init
)
8472 gfc_constructor
*ctor
;
8474 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8477 ctor
= gfc_constructor_first (init
->value
.constructor
);
8479 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8482 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8484 /* If we have an 'initialize all' constructor, do it first. */
8485 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8487 tree union_type
= TREE_TYPE (un
->backend_decl
);
8488 tree val
= build_constructor (union_type
, NULL
);
8489 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8490 ctor
= gfc_constructor_next (ctor
);
8493 /* Add the map initializer on top. */
8494 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8496 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8497 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8498 TREE_TYPE (un
->backend_decl
),
8499 un
->attr
.dimension
, un
->attr
.pointer
,
8500 un
->attr
.proc_pointer
);
8501 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8505 /* Build an expression for a constructor. If init is nonzero then
8506 this is part of a static variable initializer. */
8509 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8516 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8518 gcc_assert (se
->ss
== NULL
);
8519 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8520 type
= gfc_typenode_for_spec (&expr
->ts
);
8524 /* Create a temporary variable and fill it in. */
8525 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8526 /* The symtree in expr is NULL, if the code to generate is for
8527 initializing the static members only. */
8528 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8530 gfc_add_expr_to_block (&se
->pre
, tmp
);
8534 cm
= expr
->ts
.u
.derived
->components
;
8536 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8537 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8539 /* Skip absent members in default initializers and allocatable
8540 components. Although the latter have a default initializer
8541 of EXPR_NULL,... by default, the static nullify is not needed
8542 since this is done every time we come into scope. */
8543 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8546 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8547 && strcmp (cm
->name
, "_extends") == 0
8548 && cm
->initializer
->symtree
)
8552 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8553 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8554 vtab
= unshare_expr_without_location (vtab
);
8555 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8557 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8559 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8560 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8561 fold_convert (TREE_TYPE (cm
->backend_decl
),
8564 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8565 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8566 fold_convert (TREE_TYPE (cm
->backend_decl
),
8567 integer_zero_node
));
8568 else if (cm
->ts
.type
== BT_UNION
)
8569 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8572 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8573 TREE_TYPE (cm
->backend_decl
),
8574 cm
->attr
.dimension
, cm
->attr
.pointer
,
8575 cm
->attr
.proc_pointer
);
8576 val
= unshare_expr_without_location (val
);
8578 /* Append it to the constructor list. */
8579 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8583 se
->expr
= build_constructor (type
, v
);
8585 TREE_CONSTANT (se
->expr
) = 1;
8589 /* Translate a substring expression. */
8592 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8598 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8600 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8601 expr
->value
.character
.length
,
8602 expr
->value
.character
.string
);
8604 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8605 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8608 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8612 /* Entry point for expression translation. Evaluates a scalar quantity.
8613 EXPR is the expression to be translated, and SE is the state structure if
8614 called from within the scalarized. */
8617 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8622 if (ss
&& ss
->info
->expr
== expr
8623 && (ss
->info
->type
== GFC_SS_SCALAR
8624 || ss
->info
->type
== GFC_SS_REFERENCE
))
8626 gfc_ss_info
*ss_info
;
8629 /* Substitute a scalar expression evaluated outside the scalarization
8631 se
->expr
= ss_info
->data
.scalar
.value
;
8632 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8633 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8635 se
->string_length
= ss_info
->string_length
;
8636 gfc_advance_se_ss_chain (se
);
8640 /* We need to convert the expressions for the iso_c_binding derived types.
8641 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8642 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8643 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8644 updated to be an integer with a kind equal to the size of a (void *). */
8645 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8646 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8648 if (expr
->expr_type
== EXPR_VARIABLE
8649 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8650 || expr
->symtree
->n
.sym
->intmod_sym_id
8651 == ISOCBINDING_NULL_FUNPTR
))
8653 /* Set expr_type to EXPR_NULL, which will result in
8654 null_pointer_node being used below. */
8655 expr
->expr_type
= EXPR_NULL
;
8659 /* Update the type/kind of the expression to be what the new
8660 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8661 expr
->ts
.type
= BT_INTEGER
;
8662 expr
->ts
.f90_type
= BT_VOID
;
8663 expr
->ts
.kind
= gfc_index_integer_kind
;
8667 gfc_fix_class_refs (expr
);
8669 switch (expr
->expr_type
)
8672 gfc_conv_expr_op (se
, expr
);
8676 gfc_conv_function_expr (se
, expr
);
8680 gfc_conv_constant (se
, expr
);
8684 gfc_conv_variable (se
, expr
);
8688 se
->expr
= null_pointer_node
;
8691 case EXPR_SUBSTRING
:
8692 gfc_conv_substring_expr (se
, expr
);
8695 case EXPR_STRUCTURE
:
8696 gfc_conv_structure (se
, expr
, 0);
8700 gfc_conv_array_constructor_expr (se
, expr
);
8709 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8710 of an assignment. */
8712 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8714 gfc_conv_expr (se
, expr
);
8715 /* All numeric lvalues should have empty post chains. If not we need to
8716 figure out a way of rewriting an lvalue so that it has no post chain. */
8717 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8720 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8721 numeric expressions. Used for scalar values where inserting cleanup code
8724 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8728 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8729 gfc_conv_expr (se
, expr
);
8732 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8733 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8735 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8739 /* Helper to translate an expression and convert it to a particular type. */
8741 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8743 gfc_conv_expr_val (se
, expr
);
8744 se
->expr
= convert (type
, se
->expr
);
8748 /* Converts an expression so that it can be passed by reference. Scalar
8752 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8758 if (ss
&& ss
->info
->expr
== expr
8759 && ss
->info
->type
== GFC_SS_REFERENCE
)
8761 /* Returns a reference to the scalar evaluated outside the loop
8763 gfc_conv_expr (se
, expr
);
8765 if (expr
->ts
.type
== BT_CHARACTER
8766 && expr
->expr_type
!= EXPR_FUNCTION
)
8767 gfc_conv_string_parameter (se
);
8769 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8774 if (expr
->ts
.type
== BT_CHARACTER
)
8776 gfc_conv_expr (se
, expr
);
8777 gfc_conv_string_parameter (se
);
8781 if (expr
->expr_type
== EXPR_VARIABLE
)
8783 se
->want_pointer
= 1;
8784 gfc_conv_expr (se
, expr
);
8787 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8788 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8789 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8792 else if (add_clobber
&& expr
->ref
== NULL
)
8796 /* FIXME: This fails if var is passed by reference, see PR
8798 var
= expr
->symtree
->n
.sym
->backend_decl
;
8799 clobber
= build_clobber (TREE_TYPE (var
));
8800 gfc_add_modify (&se
->pre
, var
, clobber
);
8805 if (expr
->expr_type
== EXPR_FUNCTION
8806 && ((expr
->value
.function
.esym
8807 && expr
->value
.function
.esym
->result
->attr
.pointer
8808 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8809 || (!expr
->value
.function
.esym
&& !expr
->ref
8810 && expr
->symtree
->n
.sym
->attr
.pointer
8811 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8813 se
->want_pointer
= 1;
8814 gfc_conv_expr (se
, expr
);
8815 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8816 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8821 gfc_conv_expr (se
, expr
);
8823 /* Create a temporary var to hold the value. */
8824 if (TREE_CONSTANT (se
->expr
))
8826 tree tmp
= se
->expr
;
8827 STRIP_TYPE_NOPS (tmp
);
8828 var
= build_decl (input_location
,
8829 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8830 DECL_INITIAL (var
) = tmp
;
8831 TREE_STATIC (var
) = 1;
8836 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8837 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8840 if (!expr
->must_finalize
)
8841 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8843 /* Take the address of that value. */
8844 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8848 /* Get the _len component for an unlimited polymorphic expression. */
8851 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8854 gfc_ref
*ref
= expr
->ref
;
8856 gfc_init_se (&se
, NULL
);
8857 while (ref
&& ref
->next
)
8859 gfc_add_len_component (expr
);
8860 gfc_conv_expr (&se
, expr
);
8861 gfc_add_block_to_block (block
, &se
.pre
);
8862 gcc_assert (se
.post
.head
== NULL_TREE
);
8865 gfc_free_ref_list (ref
->next
);
8870 gfc_free_ref_list (expr
->ref
);
8877 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8878 statement-list outside of the scalarizer-loop. When code is generated, that
8879 depends on the scalarized expression, it is added to RSE.PRE.
8880 Returns le's _vptr tree and when set the len expressions in to_lenp and
8881 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8885 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8886 gfc_expr
* re
, gfc_se
*rse
,
8887 tree
* to_lenp
, tree
* from_lenp
)
8890 gfc_expr
* vptr_expr
;
8891 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8892 bool set_vptr
= false, temp_rhs
= false;
8893 stmtblock_t
*pre
= block
;
8895 /* Create a temporary for complicated expressions. */
8896 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8897 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8899 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8901 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8906 /* Get the _vptr for the left-hand side expression. */
8907 gfc_init_se (&se
, NULL
);
8908 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8909 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8911 /* Care about _len for unlimited polymorphic entities. */
8912 if (UNLIMITED_POLY (vptr_expr
)
8913 || (vptr_expr
->ts
.type
== BT_DERIVED
8914 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8915 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8916 gfc_add_vptr_component (vptr_expr
);
8920 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8921 se
.want_pointer
= 1;
8922 gfc_conv_expr (&se
, vptr_expr
);
8923 gfc_free_expr (vptr_expr
);
8924 gfc_add_block_to_block (block
, &se
.pre
);
8925 gcc_assert (se
.post
.head
== NULL_TREE
);
8927 STRIP_NOPS (lhs_vptr
);
8929 /* Set the _vptr only when the left-hand side of the assignment is a
8933 /* Get the vptr from the rhs expression only, when it is variable.
8934 Functions are expected to be assigned to a temporary beforehand. */
8935 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8936 ? gfc_find_and_cut_at_last_class_ref (re
)
8938 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8940 if (to_len
!= NULL_TREE
)
8942 /* Get the _len information from the rhs. */
8943 if (UNLIMITED_POLY (vptr_expr
)
8944 || (vptr_expr
->ts
.type
== BT_DERIVED
8945 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8946 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8948 gfc_add_vptr_component (vptr_expr
);
8952 if (re
->expr_type
== EXPR_VARIABLE
8953 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8954 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8955 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8956 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8957 re
->symtree
->n
.sym
->backend_decl
))))
8960 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8961 re
->symtree
->n
.sym
->backend_decl
));
8963 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8964 re
->symtree
->n
.sym
->backend_decl
));
8966 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8969 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8970 if (UNLIMITED_POLY (re
))
8971 from_len
= gfc_class_len_get (rse
->expr
);
8973 else if (re
->expr_type
!= EXPR_NULL
)
8974 /* Only when rhs is non-NULL use its declared type for vptr
8976 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8978 /* When the rhs is NULL use the vtab of lhs' declared type. */
8979 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8984 gfc_init_se (&se
, NULL
);
8985 se
.want_pointer
= 1;
8986 gfc_conv_expr (&se
, vptr_expr
);
8987 gfc_free_expr (vptr_expr
);
8988 gfc_add_block_to_block (block
, &se
.pre
);
8989 gcc_assert (se
.post
.head
== NULL_TREE
);
8991 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8994 if (to_len
!= NULL_TREE
)
8996 /* The _len component needs to be set. Figure how to get the
8997 value of the right-hand side. */
8998 if (from_len
== NULL_TREE
)
9000 if (rse
->string_length
!= NULL_TREE
)
9001 from_len
= rse
->string_length
;
9002 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
9004 gfc_init_se (&se
, NULL
);
9005 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
9006 gfc_add_block_to_block (block
, &se
.pre
);
9007 gcc_assert (se
.post
.head
== NULL_TREE
);
9008 from_len
= gfc_evaluate_now (se
.expr
, block
);
9011 from_len
= build_zero_cst (gfc_charlen_type_node
);
9013 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9018 /* Return the _len trees only, when requested. */
9022 *from_lenp
= from_len
;
9027 /* Assign tokens for pointer components. */
9030 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9033 symbol_attribute lhs_attr
, rhs_attr
;
9034 tree tmp
, lhs_tok
, rhs_tok
;
9035 /* Flag to indicated component refs on the rhs. */
9038 lhs_attr
= gfc_caf_attr (expr1
);
9039 if (expr2
->expr_type
!= EXPR_NULL
)
9041 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9042 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9044 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9045 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9048 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9052 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9053 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9056 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9058 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9059 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9062 else if (lhs_attr
.codimension
)
9064 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9065 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9066 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9067 lhs_tok
, null_pointer_node
);
9068 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9073 /* Do everything that is needed for a CLASS function expr2. */
9076 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9077 gfc_expr
*expr1
, gfc_expr
*expr2
)
9079 tree expr1_vptr
= NULL_TREE
;
9082 gfc_conv_function_expr (rse
, expr2
);
9083 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9085 if (expr1
->ts
.type
!= BT_CLASS
)
9086 rse
->expr
= gfc_class_data_get (rse
->expr
);
9089 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9092 gfc_add_block_to_block (block
, &rse
->pre
);
9093 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9094 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9096 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9097 fold_convert (TREE_TYPE (expr1_vptr
),
9098 gfc_class_vptr_get (tmp
)));
9099 rse
->expr
= gfc_class_data_get (tmp
);
9107 gfc_trans_pointer_assign (gfc_code
* code
)
9109 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9113 /* Generate code for a pointer assignment. */
9116 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9123 tree expr1_vptr
= NULL_TREE
;
9124 bool scalar
, non_proc_ptr_assign
;
9127 gfc_start_block (&block
);
9129 gfc_init_se (&lse
, NULL
);
9131 /* Usually testing whether this is not a proc pointer assignment. */
9132 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9133 && expr2
->expr_type
== EXPR_VARIABLE
9134 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9136 /* Check whether the expression is a scalar or not; we cannot use
9137 expr1->rank as it can be nonzero for proc pointers. */
9138 ss
= gfc_walk_expr (expr1
);
9139 scalar
= ss
== gfc_ss_terminator
;
9141 gfc_free_ss_chain (ss
);
9143 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9144 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9146 gfc_add_data_component (expr2
);
9147 /* The following is required as gfc_add_data_component doesn't
9148 update ts.type if there is a tailing REF_ARRAY. */
9149 expr2
->ts
.type
= BT_DERIVED
;
9154 /* Scalar pointers. */
9155 lse
.want_pointer
= 1;
9156 gfc_conv_expr (&lse
, expr1
);
9157 gfc_init_se (&rse
, NULL
);
9158 rse
.want_pointer
= 1;
9159 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9160 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9162 gfc_conv_expr (&rse
, expr2
);
9164 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9166 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9168 lse
.expr
= gfc_class_data_get (lse
.expr
);
9171 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9172 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9173 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9176 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9177 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9178 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9181 gfc_add_block_to_block (&block
, &lse
.pre
);
9182 gfc_add_block_to_block (&block
, &rse
.pre
);
9184 /* Check character lengths if character expression. The test is only
9185 really added if -fbounds-check is enabled. Exclude deferred
9186 character length lefthand sides. */
9187 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9188 && !expr1
->ts
.deferred
9189 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9190 && !gfc_is_proc_ptr_comp (expr1
))
9192 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9193 gcc_assert (lse
.string_length
&& rse
.string_length
);
9194 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9195 lse
.string_length
, rse
.string_length
,
9199 /* The assignment to an deferred character length sets the string
9200 length to that of the rhs. */
9201 if (expr1
->ts
.deferred
)
9203 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9204 gfc_add_modify (&block
, lse
.string_length
,
9205 fold_convert (TREE_TYPE (lse
.string_length
),
9206 rse
.string_length
));
9207 else if (lse
.string_length
!= NULL
)
9208 gfc_add_modify (&block
, lse
.string_length
,
9209 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9212 gfc_add_modify (&block
, lse
.expr
,
9213 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9215 /* Also set the tokens for pointer components in derived typed
9217 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9218 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9220 gfc_add_block_to_block (&block
, &rse
.post
);
9221 gfc_add_block_to_block (&block
, &lse
.post
);
9228 tree strlen_rhs
= NULL_TREE
;
9230 /* Array pointer. Find the last reference on the LHS and if it is an
9231 array section ref, we're dealing with bounds remapping. In this case,
9232 set it to AR_FULL so that gfc_conv_expr_descriptor does
9233 not see it and process the bounds remapping afterwards explicitly. */
9234 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9235 if (!remap
->next
&& remap
->type
== REF_ARRAY
9236 && remap
->u
.ar
.type
== AR_SECTION
)
9238 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9240 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
9242 gfc_error ("If bounds remapping is specified at %L, "
9243 "the pointer target shall not be NULL", &expr1
->where
);
9247 gfc_init_se (&lse
, NULL
);
9249 lse
.descriptor_only
= 1;
9250 gfc_conv_expr_descriptor (&lse
, expr1
);
9251 strlen_lhs
= lse
.string_length
;
9254 if (expr2
->expr_type
== EXPR_NULL
)
9256 /* Just set the data pointer to null. */
9257 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9259 else if (rank_remap
)
9261 /* If we are rank-remapping, just get the RHS's descriptor and
9262 process this later on. */
9263 gfc_init_se (&rse
, NULL
);
9264 rse
.direct_byref
= 1;
9265 rse
.byref_noassign
= 1;
9267 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9268 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
9270 else if (expr2
->expr_type
== EXPR_FUNCTION
)
9272 tree bound
[GFC_MAX_DIMENSIONS
];
9275 for (i
= 0; i
< expr2
->rank
; i
++)
9276 bound
[i
] = NULL_TREE
;
9277 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
9278 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
9280 GFC_ARRAY_POINTER_CONT
, false);
9281 tmp
= gfc_create_var (tmp
, "ptrtemp");
9282 rse
.descriptor_only
= 0;
9284 rse
.direct_byref
= 1;
9285 gfc_conv_expr_descriptor (&rse
, expr2
);
9286 strlen_rhs
= rse
.string_length
;
9291 gfc_conv_expr_descriptor (&rse
, expr2
);
9292 strlen_rhs
= rse
.string_length
;
9293 if (expr1
->ts
.type
== BT_CLASS
)
9294 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9299 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9301 /* Assign directly to the LHS's descriptor. */
9302 lse
.descriptor_only
= 0;
9303 lse
.direct_byref
= 1;
9304 gfc_conv_expr_descriptor (&lse
, expr2
);
9305 strlen_rhs
= lse
.string_length
;
9307 if (expr1
->ts
.type
== BT_CLASS
)
9309 rse
.expr
= NULL_TREE
;
9310 rse
.string_length
= NULL_TREE
;
9311 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
9317 /* If the target is not a whole array, use the target array
9318 reference for remap. */
9319 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
9320 if (remap
->type
== REF_ARRAY
9321 && remap
->u
.ar
.type
== AR_FULL
9326 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9328 gfc_init_se (&rse
, NULL
);
9329 rse
.want_pointer
= 1;
9330 gfc_conv_function_expr (&rse
, expr2
);
9331 if (expr1
->ts
.type
!= BT_CLASS
)
9333 rse
.expr
= gfc_class_data_get (rse
.expr
);
9334 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9335 /* Set the lhs span. */
9336 tmp
= TREE_TYPE (rse
.expr
);
9337 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9338 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9339 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
9343 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9346 gfc_add_block_to_block (&block
, &rse
.pre
);
9347 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
9348 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
9350 gfc_add_modify (&lse
.pre
, expr1_vptr
,
9351 fold_convert (TREE_TYPE (expr1_vptr
),
9352 gfc_class_vptr_get (tmp
)));
9353 rse
.expr
= gfc_class_data_get (tmp
);
9354 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9359 /* Assign to a temporary descriptor and then copy that
9360 temporary to the pointer. */
9361 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
9362 lse
.descriptor_only
= 0;
9364 lse
.direct_byref
= 1;
9365 gfc_conv_expr_descriptor (&lse
, expr2
);
9366 strlen_rhs
= lse
.string_length
;
9367 gfc_add_modify (&lse
.pre
, desc
, tmp
);
9370 gfc_add_block_to_block (&block
, &lse
.pre
);
9372 gfc_add_block_to_block (&block
, &rse
.pre
);
9374 /* If we do bounds remapping, update LHS descriptor accordingly. */
9378 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
9382 /* Do rank remapping. We already have the RHS's descriptor
9383 converted in rse and now have to build the correct LHS
9384 descriptor for it. */
9386 tree dtype
, data
, span
;
9388 tree lbound
, ubound
;
9391 dtype
= gfc_conv_descriptor_dtype (desc
);
9392 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
9393 gfc_add_modify (&block
, dtype
, tmp
);
9395 /* Copy data pointer. */
9396 data
= gfc_conv_descriptor_data_get (rse
.expr
);
9397 gfc_conv_descriptor_data_set (&block
, desc
, data
);
9399 /* Copy the span. */
9400 if (TREE_CODE (rse
.expr
) == VAR_DECL
9401 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
9402 span
= gfc_conv_descriptor_span_get (rse
.expr
);
9405 tmp
= TREE_TYPE (rse
.expr
);
9406 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9407 span
= fold_convert (gfc_array_index_type
, tmp
);
9409 gfc_conv_descriptor_span_set (&block
, desc
, span
);
9411 /* Copy offset but adjust it such that it would correspond
9412 to a lbound of zero. */
9413 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
9414 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
9416 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9418 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
9420 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9421 gfc_array_index_type
, stride
, lbound
);
9422 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9423 gfc_array_index_type
, offs
, tmp
);
9425 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9427 /* Set the bounds as declared for the LHS and calculate strides as
9428 well as another offset update accordingly. */
9429 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9431 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9436 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9438 /* Convert declared bounds. */
9439 gfc_init_se (&lower_se
, NULL
);
9440 gfc_init_se (&upper_se
, NULL
);
9441 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9442 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9444 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9445 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9447 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9448 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9450 lbound
= gfc_evaluate_now (lbound
, &block
);
9451 ubound
= gfc_evaluate_now (ubound
, &block
);
9453 gfc_add_block_to_block (&block
, &lower_se
.post
);
9454 gfc_add_block_to_block (&block
, &upper_se
.post
);
9456 /* Set bounds in descriptor. */
9457 gfc_conv_descriptor_lbound_set (&block
, desc
,
9458 gfc_rank_cst
[dim
], lbound
);
9459 gfc_conv_descriptor_ubound_set (&block
, desc
,
9460 gfc_rank_cst
[dim
], ubound
);
9463 stride
= gfc_evaluate_now (stride
, &block
);
9464 gfc_conv_descriptor_stride_set (&block
, desc
,
9465 gfc_rank_cst
[dim
], stride
);
9467 /* Update offset. */
9468 offs
= gfc_conv_descriptor_offset_get (desc
);
9469 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9470 gfc_array_index_type
, lbound
, stride
);
9471 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9472 gfc_array_index_type
, offs
, tmp
);
9473 offs
= gfc_evaluate_now (offs
, &block
);
9474 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9476 /* Update stride. */
9477 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9478 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9479 gfc_array_index_type
, stride
, tmp
);
9484 /* Bounds remapping. Just shift the lower bounds. */
9486 gcc_assert (expr1
->rank
== expr2
->rank
);
9488 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9492 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9493 gfc_init_se (&lbound_se
, NULL
);
9494 if (remap
->u
.ar
.start
[dim
])
9496 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9497 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9500 /* This remap arises from a target that is not a whole
9501 array. The start expressions will be NULL but we need
9502 the lbounds to be one. */
9503 lbound_se
.expr
= gfc_index_one_node
;
9504 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9505 dim
, lbound_se
.expr
);
9506 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9511 /* If rank remapping was done, check with -fcheck=bounds that
9512 the target is at least as large as the pointer. */
9513 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9519 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9520 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9522 lsize
= gfc_evaluate_now (lsize
, &block
);
9523 rsize
= gfc_evaluate_now (rsize
, &block
);
9524 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9527 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9528 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9532 if (expr1
->ts
.type
== BT_CHARACTER
9533 && expr1
->symtree
->n
.sym
->ts
.deferred
9534 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9535 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9537 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9538 if (expr2
->expr_type
!= EXPR_NULL
)
9539 gfc_add_modify (&block
, tmp
,
9540 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9542 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9545 /* Check string lengths if applicable. The check is only really added
9546 to the output code if -fbounds-check is enabled. */
9547 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9549 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9550 gcc_assert (strlen_lhs
&& strlen_rhs
);
9551 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9552 strlen_lhs
, strlen_rhs
, &block
);
9555 gfc_add_block_to_block (&block
, &lse
.post
);
9557 gfc_add_block_to_block (&block
, &rse
.post
);
9560 return gfc_finish_block (&block
);
9564 /* Makes sure se is suitable for passing as a function string parameter. */
9565 /* TODO: Need to check all callers of this function. It may be abused. */
9568 gfc_conv_string_parameter (gfc_se
* se
)
9572 if (TREE_CODE (se
->expr
) == STRING_CST
)
9574 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9575 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9579 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
9580 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
9581 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9583 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9585 type
= TREE_TYPE (se
->expr
);
9586 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9590 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9592 type
= build_pointer_type (type
);
9593 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9597 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9601 /* Generate code for assignment of scalar variables. Includes character
9602 strings and derived types with allocatable components.
9603 If you know that the LHS has no allocations, set dealloc to false.
9605 DEEP_COPY has no effect if the typespec TS is not a derived type with
9606 allocatable components. Otherwise, if it is set, an explicit copy of each
9607 allocatable component is made. This is necessary as a simple copy of the
9608 whole object would copy array descriptors as is, so that the lhs's
9609 allocatable components would point to the rhs's after the assignment.
9610 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9611 necessary if the rhs is a non-pointer function, as the allocatable components
9612 are not accessible by other means than the function's result after the
9613 function has returned. It is even more subtle when temporaries are involved,
9614 as the two following examples show:
9615 1. When we evaluate an array constructor, a temporary is created. Thus
9616 there is theoretically no alias possible. However, no deep copy is
9617 made for this temporary, so that if the constructor is made of one or
9618 more variable with allocatable components, those components still point
9619 to the variable's: DEEP_COPY should be set for the assignment from the
9620 temporary to the lhs in that case.
9621 2. When assigning a scalar to an array, we evaluate the scalar value out
9622 of the loop, store it into a temporary variable, and assign from that.
9623 In that case, deep copying when assigning to the temporary would be a
9624 waste of resources; however deep copies should happen when assigning from
9625 the temporary to each array element: again DEEP_COPY should be set for
9626 the assignment from the temporary to the lhs. */
9629 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9630 bool deep_copy
, bool dealloc
, bool in_coarray
)
9636 gfc_init_block (&block
);
9638 if (ts
.type
== BT_CHARACTER
)
9643 if (lse
->string_length
!= NULL_TREE
)
9645 gfc_conv_string_parameter (lse
);
9646 gfc_add_block_to_block (&block
, &lse
->pre
);
9647 llen
= lse
->string_length
;
9650 if (rse
->string_length
!= NULL_TREE
)
9652 gfc_conv_string_parameter (rse
);
9653 gfc_add_block_to_block (&block
, &rse
->pre
);
9654 rlen
= rse
->string_length
;
9657 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9658 rse
->expr
, ts
.kind
);
9660 else if (gfc_bt_struct (ts
.type
)
9661 && (ts
.u
.derived
->attr
.alloc_comp
9662 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9664 tree tmp_var
= NULL_TREE
;
9667 /* Are the rhs and the lhs the same? */
9670 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9671 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9672 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9673 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9676 /* Deallocate the lhs allocated components as long as it is not
9677 the same as the rhs. This must be done following the assignment
9678 to prevent deallocating data that could be used in the rhs
9682 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9683 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9685 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9687 gfc_add_expr_to_block (&lse
->post
, tmp
);
9690 gfc_add_block_to_block (&block
, &rse
->pre
);
9691 gfc_add_block_to_block (&block
, &lse
->pre
);
9693 gfc_add_modify (&block
, lse
->expr
,
9694 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9696 /* Restore pointer address of coarray components. */
9697 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9699 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9700 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9702 gfc_add_expr_to_block (&block
, tmp
);
9705 /* Do a deep copy if the rhs is a variable, if it is not the
9709 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9710 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9711 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9713 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9715 gfc_add_expr_to_block (&block
, tmp
);
9718 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
9720 gfc_add_block_to_block (&block
, &lse
->pre
);
9721 gfc_add_block_to_block (&block
, &rse
->pre
);
9722 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9723 TREE_TYPE (lse
->expr
), rse
->expr
);
9724 gfc_add_modify (&block
, lse
->expr
, tmp
);
9728 gfc_add_block_to_block (&block
, &lse
->pre
);
9729 gfc_add_block_to_block (&block
, &rse
->pre
);
9731 gfc_add_modify (&block
, lse
->expr
,
9732 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9735 gfc_add_block_to_block (&block
, &lse
->post
);
9736 gfc_add_block_to_block (&block
, &rse
->post
);
9738 return gfc_finish_block (&block
);
9742 /* There are quite a lot of restrictions on the optimisation in using an
9743 array function assign without a temporary. */
9746 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9749 bool seen_array_ref
;
9751 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9753 /* Play it safe with class functions assigned to a derived type. */
9754 if (gfc_is_class_array_function (expr2
)
9755 && expr1
->ts
.type
== BT_DERIVED
)
9758 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9759 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9762 /* Elemental functions are scalarized so that they don't need a
9763 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9764 they would need special treatment in gfc_trans_arrayfunc_assign. */
9765 if (expr2
->value
.function
.esym
!= NULL
9766 && expr2
->value
.function
.esym
->attr
.elemental
)
9769 /* Need a temporary if rhs is not FULL or a contiguous section. */
9770 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9773 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9774 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9777 /* Functions returning pointers or allocatables need temporaries. */
9778 c
= expr2
->value
.function
.esym
9779 ? (expr2
->value
.function
.esym
->attr
.pointer
9780 || expr2
->value
.function
.esym
->attr
.allocatable
)
9781 : (expr2
->symtree
->n
.sym
->attr
.pointer
9782 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9786 /* Character array functions need temporaries unless the
9787 character lengths are the same. */
9788 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9790 if (expr1
->ts
.u
.cl
->length
== NULL
9791 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9794 if (expr2
->ts
.u
.cl
->length
== NULL
9795 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9798 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9799 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9803 /* Check that no LHS component references appear during an array
9804 reference. This is needed because we do not have the means to
9805 span any arbitrary stride with an array descriptor. This check
9806 is not needed for the rhs because the function result has to be
9808 seen_array_ref
= false;
9809 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9811 if (ref
->type
== REF_ARRAY
)
9812 seen_array_ref
= true;
9813 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9817 /* Check for a dependency. */
9818 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9819 expr2
->value
.function
.esym
,
9820 expr2
->value
.function
.actual
,
9824 /* If we have reached here with an intrinsic function, we do not
9825 need a temporary except in the particular case that reallocation
9826 on assignment is active and the lhs is allocatable and a target,
9827 or a pointer which may be a subref pointer. FIXME: The last
9828 condition can go away when we use span in the intrinsics
9830 if (expr2
->value
.function
.isym
)
9831 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
)
9832 || (sym
->attr
.pointer
&& sym
->attr
.subref_array_pointer
);
9834 /* If the LHS is a dummy, we need a temporary if it is not
9836 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9839 /* If the lhs has been host_associated, is in common, a pointer or is
9840 a target and the function is not using a RESULT variable, aliasing
9841 can occur and a temporary is needed. */
9842 if ((sym
->attr
.host_assoc
9843 || sym
->attr
.in_common
9844 || sym
->attr
.pointer
9845 || sym
->attr
.cray_pointee
9846 || sym
->attr
.target
)
9847 && expr2
->symtree
!= NULL
9848 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9851 /* A PURE function can unconditionally be called without a temporary. */
9852 if (expr2
->value
.function
.esym
!= NULL
9853 && expr2
->value
.function
.esym
->attr
.pure
)
9856 /* Implicit_pure functions are those which could legally be declared
9858 if (expr2
->value
.function
.esym
!= NULL
9859 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9862 if (!sym
->attr
.use_assoc
9863 && !sym
->attr
.in_common
9864 && !sym
->attr
.pointer
9865 && !sym
->attr
.target
9866 && !sym
->attr
.cray_pointee
9867 && expr2
->value
.function
.esym
)
9869 /* A temporary is not needed if the function is not contained and
9870 the variable is local or host associated and not a pointer or
9872 if (!expr2
->value
.function
.esym
->attr
.contained
)
9875 /* A temporary is not needed if the lhs has never been host
9876 associated and the procedure is contained. */
9877 else if (!sym
->attr
.host_assoc
)
9880 /* A temporary is not needed if the variable is local and not
9881 a pointer, a target or a result. */
9883 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9887 /* Default to temporary use. */
9892 /* Provide the loop info so that the lhs descriptor can be built for
9893 reallocatable assignments from extrinsic function calls. */
9896 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9899 /* Signal that the function call should not be made by
9900 gfc_conv_loop_setup. */
9901 se
->ss
->is_alloc_lhs
= 1;
9902 gfc_init_loopinfo (loop
);
9903 gfc_add_ss_to_loop (loop
, *ss
);
9904 gfc_add_ss_to_loop (loop
, se
->ss
);
9905 gfc_conv_ss_startstride (loop
);
9906 gfc_conv_loop_setup (loop
, where
);
9907 gfc_copy_loopinfo_to_se (se
, loop
);
9908 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9909 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9910 se
->ss
->is_alloc_lhs
= 0;
9914 /* For assignment to a reallocatable lhs from intrinsic functions,
9915 replace the se.expr (ie. the result) with a temporary descriptor.
9916 Null the data field so that the library allocates space for the
9917 result. Free the data of the original descriptor after the function,
9918 in case it appears in an argument expression and transfer the
9919 result to the original descriptor. */
9922 fcncall_realloc_result (gfc_se
*se
, int rank
)
9931 /* Use the allocation done by the library. Substitute the lhs
9932 descriptor with a copy, whose data field is nulled.*/
9933 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9934 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9935 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9937 /* Unallocated, the descriptor does not have a dtype. */
9938 tmp
= gfc_conv_descriptor_dtype (desc
);
9939 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9941 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9942 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9943 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9945 /* Free the lhs after the function call and copy the result data to
9946 the lhs descriptor. */
9947 tmp
= gfc_conv_descriptor_data_get (desc
);
9948 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9949 logical_type_node
, tmp
,
9950 build_int_cst (TREE_TYPE (tmp
), 0));
9951 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9952 tmp
= gfc_call_free (tmp
);
9953 gfc_add_expr_to_block (&se
->post
, tmp
);
9955 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9956 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9958 /* Check that the shapes are the same between lhs and expression. */
9959 for (n
= 0 ; n
< rank
; n
++)
9962 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9963 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9964 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9965 gfc_array_index_type
, tmp
, tmp1
);
9966 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9967 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9968 gfc_array_index_type
, tmp
, tmp1
);
9969 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9970 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9971 gfc_array_index_type
, tmp
, tmp1
);
9972 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9973 logical_type_node
, tmp
,
9974 gfc_index_zero_node
);
9975 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9976 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9977 logical_type_node
, tmp
,
9981 /* 'zero_cond' being true is equal to lhs not being allocated or the
9982 shapes being different. */
9983 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9985 /* Now reset the bounds returned from the function call to bounds based
9986 on the lhs lbounds, except where the lhs is not allocated or the shapes
9987 of 'variable and 'expr' are different. Set the offset accordingly. */
9988 offset
= gfc_index_zero_node
;
9989 for (n
= 0 ; n
< rank
; n
++)
9993 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9994 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9995 gfc_array_index_type
, zero_cond
,
9996 gfc_index_one_node
, lbound
);
9997 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9999 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10000 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10001 gfc_array_index_type
, tmp
, lbound
);
10002 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
10003 gfc_rank_cst
[n
], lbound
);
10004 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
10005 gfc_rank_cst
[n
], tmp
);
10007 /* Set stride and accumulate the offset. */
10008 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
10009 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
10010 gfc_rank_cst
[n
], tmp
);
10011 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10012 gfc_array_index_type
, lbound
, tmp
);
10013 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10014 gfc_array_index_type
, offset
, tmp
);
10015 offset
= gfc_evaluate_now (offset
, &se
->post
);
10018 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10023 /* Try to translate array(:) = func (...), where func is a transformational
10024 array function, without using a temporary. Returns NULL if this isn't the
10028 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10032 gfc_component
*comp
= NULL
;
10035 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10038 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10040 comp
= gfc_get_proc_ptr_comp (expr2
);
10042 if (!(expr2
->value
.function
.isym
10043 || (comp
&& comp
->attr
.dimension
)
10044 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10045 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10048 gfc_init_se (&se
, NULL
);
10049 gfc_start_block (&se
.pre
);
10050 se
.want_pointer
= 1;
10052 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10054 if (expr1
->ts
.type
== BT_DERIVED
10055 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10058 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10060 gfc_add_expr_to_block (&se
.pre
, tmp
);
10063 se
.direct_byref
= 1;
10064 se
.ss
= gfc_walk_expr (expr2
);
10065 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10067 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10068 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10069 Clearly, this cannot be done for an allocatable function result, since
10070 the shape of the result is unknown and, in any case, the function must
10071 correctly take care of the reallocation internally. For intrinsic
10072 calls, the array data is freed and the library takes care of allocation.
10073 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10075 if (flag_realloc_lhs
10076 && gfc_is_reallocatable_lhs (expr1
)
10077 && !gfc_expr_attr (expr1
).codimension
10078 && !gfc_is_coindexed (expr1
)
10079 && !(expr2
->value
.function
.esym
10080 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10082 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10084 if (!expr2
->value
.function
.isym
)
10086 ss
= gfc_walk_expr (expr1
);
10087 gcc_assert (ss
!= gfc_ss_terminator
);
10089 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10090 ss
->is_alloc_lhs
= 1;
10093 fcncall_realloc_result (&se
, expr1
->rank
);
10096 gfc_conv_function_expr (&se
, expr2
);
10097 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10100 gfc_cleanup_loop (&loop
);
10102 gfc_free_ss_chain (se
.ss
);
10104 return gfc_finish_block (&se
.pre
);
10108 /* Try to efficiently translate array(:) = 0. Return NULL if this
10112 gfc_trans_zero_assign (gfc_expr
* expr
)
10114 tree dest
, len
, type
;
10118 sym
= expr
->symtree
->n
.sym
;
10119 dest
= gfc_get_symbol_decl (sym
);
10121 type
= TREE_TYPE (dest
);
10122 if (POINTER_TYPE_P (type
))
10123 type
= TREE_TYPE (type
);
10124 if (!GFC_ARRAY_TYPE_P (type
))
10127 /* Determine the length of the array. */
10128 len
= GFC_TYPE_ARRAY_SIZE (type
);
10129 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10132 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10133 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10134 fold_convert (gfc_array_index_type
, tmp
));
10136 /* If we are zeroing a local array avoid taking its address by emitting
10138 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10139 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10140 dest
, build_constructor (TREE_TYPE (dest
),
10143 /* Convert arguments to the correct types. */
10144 dest
= fold_convert (pvoid_type_node
, dest
);
10145 len
= fold_convert (size_type_node
, len
);
10147 /* Construct call to __builtin_memset. */
10148 tmp
= build_call_expr_loc (input_location
,
10149 builtin_decl_explicit (BUILT_IN_MEMSET
),
10150 3, dest
, integer_zero_node
, len
);
10151 return fold_convert (void_type_node
, tmp
);
10155 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10156 that constructs the call to __builtin_memcpy. */
10159 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10163 /* Convert arguments to the correct types. */
10164 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10165 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10167 dst
= fold_convert (pvoid_type_node
, dst
);
10169 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10170 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10172 src
= fold_convert (pvoid_type_node
, src
);
10174 len
= fold_convert (size_type_node
, len
);
10176 /* Construct call to __builtin_memcpy. */
10177 tmp
= build_call_expr_loc (input_location
,
10178 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10180 return fold_convert (void_type_node
, tmp
);
10184 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10185 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10186 source/rhs, both are gfc_full_array_ref_p which have been checked for
10190 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10192 tree dst
, dlen
, dtype
;
10193 tree src
, slen
, stype
;
10196 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10197 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10199 dtype
= TREE_TYPE (dst
);
10200 if (POINTER_TYPE_P (dtype
))
10201 dtype
= TREE_TYPE (dtype
);
10202 stype
= TREE_TYPE (src
);
10203 if (POINTER_TYPE_P (stype
))
10204 stype
= TREE_TYPE (stype
);
10206 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10209 /* Determine the lengths of the arrays. */
10210 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10211 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10213 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10214 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10215 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10217 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10218 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10220 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10221 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10222 slen
, fold_convert (gfc_array_index_type
, tmp
));
10224 /* Sanity check that they are the same. This should always be
10225 the case, as we should already have checked for conformance. */
10226 if (!tree_int_cst_equal (slen
, dlen
))
10229 return gfc_build_memcpy_call (dst
, src
, dlen
);
10233 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10234 this can't be done. EXPR1 is the destination/lhs for which
10235 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10238 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10240 unsigned HOST_WIDE_INT nelem
;
10246 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
10250 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10251 dtype
= TREE_TYPE (dst
);
10252 if (POINTER_TYPE_P (dtype
))
10253 dtype
= TREE_TYPE (dtype
);
10254 if (!GFC_ARRAY_TYPE_P (dtype
))
10257 /* Determine the lengths of the array. */
10258 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
10259 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10262 /* Confirm that the constructor is the same size. */
10263 if (compare_tree_int (len
, nelem
) != 0)
10266 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10267 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10268 fold_convert (gfc_array_index_type
, tmp
));
10270 stype
= gfc_typenode_for_spec (&expr2
->ts
);
10271 src
= gfc_build_constant_array_constructor (expr2
, stype
);
10273 return gfc_build_memcpy_call (dst
, src
, len
);
10277 /* Tells whether the expression is to be treated as a variable reference. */
10280 gfc_expr_is_variable (gfc_expr
*expr
)
10283 gfc_component
*comp
;
10284 gfc_symbol
*func_ifc
;
10286 if (expr
->expr_type
== EXPR_VARIABLE
)
10289 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
10292 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
10293 return gfc_expr_is_variable (arg
);
10296 /* A data-pointer-returning function should be considered as a variable
10298 if (expr
->expr_type
== EXPR_FUNCTION
10299 && expr
->ref
== NULL
)
10301 if (expr
->value
.function
.isym
!= NULL
)
10304 if (expr
->value
.function
.esym
!= NULL
)
10306 func_ifc
= expr
->value
.function
.esym
;
10311 gcc_assert (expr
->symtree
);
10312 func_ifc
= expr
->symtree
->n
.sym
;
10316 gcc_unreachable ();
10319 comp
= gfc_get_proc_ptr_comp (expr
);
10320 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
10323 func_ifc
= comp
->ts
.interface
;
10327 if (expr
->expr_type
== EXPR_COMPCALL
)
10329 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
10330 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
10337 gcc_assert (func_ifc
->attr
.function
10338 && func_ifc
->result
!= NULL
);
10339 return func_ifc
->result
->attr
.pointer
;
10343 /* Is the lhs OK for automatic reallocation? */
10346 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
10350 /* An allocatable variable with no reference. */
10351 if (expr
->symtree
->n
.sym
->attr
.allocatable
10355 /* All that can be left are allocatable components. However, we do
10356 not check for allocatable components here because the expression
10357 could be an allocatable component of a pointer component. */
10358 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10359 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
10362 /* Find an allocatable component ref last. */
10363 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10364 if (ref
->type
== REF_COMPONENT
10366 && ref
->u
.c
.component
->attr
.allocatable
)
10373 /* Allocate or reallocate scalar lhs, as necessary. */
10376 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
10377 tree string_length
,
10385 tree size_in_bytes
;
10391 if (!expr1
|| expr1
->rank
)
10394 if (!expr2
|| expr2
->rank
)
10397 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10398 if (ref
->type
== REF_SUBSTRING
)
10401 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
10403 /* Since this is a scalar lhs, we can afford to do this. That is,
10404 there is no risk of side effects being repeated. */
10405 gfc_init_se (&lse
, NULL
);
10406 lse
.want_pointer
= 1;
10407 gfc_conv_expr (&lse
, expr1
);
10409 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10410 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10412 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10413 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
10414 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10416 tmp
= build3_v (COND_EXPR
, cond
,
10417 build1_v (GOTO_EXPR
, jump_label1
),
10418 build_empty_stmt (input_location
));
10419 gfc_add_expr_to_block (block
, tmp
);
10421 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10423 /* Use the rhs string length and the lhs element size. */
10424 size
= string_length
;
10425 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10426 tmp
= TYPE_SIZE_UNIT (tmp
);
10427 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10428 TREE_TYPE (tmp
), tmp
,
10429 fold_convert (TREE_TYPE (tmp
), size
));
10433 /* Otherwise use the length in bytes of the rhs. */
10434 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10435 size_in_bytes
= size
;
10438 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10439 size_in_bytes
, size_one_node
);
10441 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10443 tree caf_decl
, token
;
10445 symbol_attribute attr
;
10447 gfc_clear_attr (&attr
);
10448 gfc_init_se (&caf_se
, NULL
);
10450 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10451 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10453 gfc_add_block_to_block (block
, &caf_se
.pre
);
10454 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10455 gfc_build_addr_expr (NULL_TREE
, token
),
10456 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10459 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10461 tmp
= build_call_expr_loc (input_location
,
10462 builtin_decl_explicit (BUILT_IN_CALLOC
),
10463 2, build_one_cst (size_type_node
),
10465 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10466 gfc_add_modify (block
, lse
.expr
, tmp
);
10470 tmp
= build_call_expr_loc (input_location
,
10471 builtin_decl_explicit (BUILT_IN_MALLOC
),
10473 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10474 gfc_add_modify (block
, lse
.expr
, tmp
);
10477 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10479 /* Deferred characters need checking for lhs and rhs string
10480 length. Other deferred parameter variables will have to
10482 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10483 gfc_add_expr_to_block (block
, tmp
);
10485 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10486 gfc_add_expr_to_block (block
, tmp
);
10488 /* For a deferred length character, reallocate if lengths of lhs and
10489 rhs are different. */
10490 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10492 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10494 fold_convert (TREE_TYPE (lse
.string_length
),
10496 /* Jump past the realloc if the lengths are the same. */
10497 tmp
= build3_v (COND_EXPR
, cond
,
10498 build1_v (GOTO_EXPR
, jump_label2
),
10499 build_empty_stmt (input_location
));
10500 gfc_add_expr_to_block (block
, tmp
);
10501 tmp
= build_call_expr_loc (input_location
,
10502 builtin_decl_explicit (BUILT_IN_REALLOC
),
10503 2, fold_convert (pvoid_type_node
, lse
.expr
),
10505 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10506 gfc_add_modify (block
, lse
.expr
, tmp
);
10507 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10508 gfc_add_expr_to_block (block
, tmp
);
10510 /* Update the lhs character length. */
10511 size
= string_length
;
10512 gfc_add_modify (block
, lse
.string_length
,
10513 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10517 /* Check for assignments of the type
10521 to make sure we do not check for reallocation unneccessarily. */
10525 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10527 gfc_actual_arglist
*a
;
10530 switch (expr2
->expr_type
)
10532 case EXPR_VARIABLE
:
10533 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10535 case EXPR_FUNCTION
:
10536 if (expr2
->value
.function
.esym
10537 && expr2
->value
.function
.esym
->attr
.elemental
)
10539 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10542 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10547 else if (expr2
->value
.function
.isym
10548 && expr2
->value
.function
.isym
->elemental
)
10550 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10553 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10562 switch (expr2
->value
.op
.op
)
10564 case INTRINSIC_NOT
:
10565 case INTRINSIC_UPLUS
:
10566 case INTRINSIC_UMINUS
:
10567 case INTRINSIC_PARENTHESES
:
10568 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10570 case INTRINSIC_PLUS
:
10571 case INTRINSIC_MINUS
:
10572 case INTRINSIC_TIMES
:
10573 case INTRINSIC_DIVIDE
:
10574 case INTRINSIC_POWER
:
10575 case INTRINSIC_AND
:
10577 case INTRINSIC_EQV
:
10578 case INTRINSIC_NEQV
:
10585 case INTRINSIC_EQ_OS
:
10586 case INTRINSIC_NE_OS
:
10587 case INTRINSIC_GT_OS
:
10588 case INTRINSIC_GE_OS
:
10589 case INTRINSIC_LT_OS
:
10590 case INTRINSIC_LE_OS
:
10592 e1
= expr2
->value
.op
.op1
;
10593 e2
= expr2
->value
.op
.op2
;
10595 if (e1
->rank
== 0 && e2
->rank
> 0)
10596 return is_runtime_conformable (expr1
, e2
);
10597 else if (e1
->rank
> 0 && e2
->rank
== 0)
10598 return is_runtime_conformable (expr1
, e1
);
10599 else if (e1
->rank
> 0 && e2
->rank
> 0)
10600 return is_runtime_conformable (expr1
, e1
)
10601 && is_runtime_conformable (expr1
, e2
);
10619 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10620 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10621 bool class_realloc
)
10623 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
10624 vec
<tree
, va_gc
> *args
= NULL
;
10626 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10629 /* Generate allocation of the lhs. */
10635 tmp
= gfc_vptr_size_get (vptr
);
10636 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10637 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10638 gfc_init_block (&alloc
);
10639 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
10640 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10641 logical_type_node
, class_han
,
10642 build_int_cst (prvoid_type_node
, 0));
10643 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10645 PRED_FORTRAN_FAIL_ALLOC
),
10646 gfc_finish_block (&alloc
),
10647 build_empty_stmt (input_location
));
10648 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10651 fcn
= gfc_vptr_copy_get (vptr
);
10653 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10654 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10657 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10658 || INDIRECT_REF_P (tmp
)
10659 || (rhs
->ts
.type
== BT_DERIVED
10660 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10661 && !rhs
->ts
.u
.derived
->attr
.pointer
10662 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10663 || (UNLIMITED_POLY (rhs
)
10664 && !CLASS_DATA (rhs
)->attr
.pointer
10665 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10666 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10668 vec_safe_push (args
, tmp
);
10669 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10670 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10671 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10672 || INDIRECT_REF_P (tmp
)
10673 || (lhs
->ts
.type
== BT_DERIVED
10674 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10675 && !lhs
->ts
.u
.derived
->attr
.pointer
10676 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10677 || (UNLIMITED_POLY (lhs
)
10678 && !CLASS_DATA (lhs
)->attr
.pointer
10679 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10680 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10682 vec_safe_push (args
, tmp
);
10684 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10686 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10689 vec_safe_push (args
, from_len
);
10690 vec_safe_push (args
, to_len
);
10691 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10693 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10694 logical_type_node
, from_len
,
10695 build_zero_cst (TREE_TYPE (from_len
)));
10696 return fold_build3_loc (input_location
, COND_EXPR
,
10697 void_type_node
, tmp
,
10705 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10706 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10707 stmtblock_t tblock
;
10708 gfc_init_block (&tblock
);
10709 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10710 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10711 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10712 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10713 /* When coming from a ptr_copy lhs and rhs are swapped. */
10714 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10715 fold_convert (TREE_TYPE (rhst
), tmp
));
10716 return gfc_finish_block (&tblock
);
10720 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10721 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10722 init_flag indicates initialization expressions and dealloc that no
10723 deallocate prior assignment is needed (if in doubt, set true).
10724 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10725 routine instead of a pointer assignment. Alias resolution is only done,
10726 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10727 where it is known, that newly allocated memory on the lhs can never be
10728 an alias of the rhs. */
10731 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10732 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10737 gfc_ss
*lss_section
;
10744 bool scalar_to_array
;
10745 tree string_length
;
10747 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10748 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10749 bool is_poly_assign
;
10751 /* Assignment of the form lhs = rhs. */
10752 gfc_start_block (&block
);
10754 gfc_init_se (&lse
, NULL
);
10755 gfc_init_se (&rse
, NULL
);
10757 /* Walk the lhs. */
10758 lss
= gfc_walk_expr (expr1
);
10759 if (gfc_is_reallocatable_lhs (expr1
))
10761 lss
->no_bounds_check
= 1;
10762 if (!(expr2
->expr_type
== EXPR_FUNCTION
10763 && expr2
->value
.function
.isym
!= NULL
10764 && !(expr2
->value
.function
.isym
->elemental
10765 || expr2
->value
.function
.isym
->conversion
)))
10766 lss
->is_alloc_lhs
= 1;
10769 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10773 if ((expr1
->ts
.type
== BT_DERIVED
)
10774 && (gfc_is_class_array_function (expr2
)
10775 || gfc_is_alloc_class_scalar_function (expr2
)))
10776 expr2
->must_finalize
= 1;
10778 /* Checking whether a class assignment is desired is quite complicated and
10779 needed at two locations, so do it once only before the information is
10781 lhs_attr
= gfc_expr_attr (expr1
);
10782 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10783 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10784 && (expr1
->ts
.type
== BT_CLASS
10785 || gfc_is_class_array_ref (expr1
, NULL
)
10786 || gfc_is_class_scalar_expr (expr1
)
10787 || gfc_is_class_array_ref (expr2
, NULL
)
10788 || gfc_is_class_scalar_expr (expr2
));
10791 /* Only analyze the expressions for coarray properties, when in coarray-lib
10793 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10795 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10796 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10799 if (lss
!= gfc_ss_terminator
)
10801 /* The assignment needs scalarization. */
10804 /* Find a non-scalar SS from the lhs. */
10805 while (lss_section
!= gfc_ss_terminator
10806 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10807 lss_section
= lss_section
->next
;
10809 gcc_assert (lss_section
!= gfc_ss_terminator
);
10811 /* Initialize the scalarizer. */
10812 gfc_init_loopinfo (&loop
);
10814 /* Walk the rhs. */
10815 rss
= gfc_walk_expr (expr2
);
10816 if (rss
== gfc_ss_terminator
)
10817 /* The rhs is scalar. Add a ss for the expression. */
10818 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10819 /* When doing a class assign, then the handle to the rhs needs to be a
10820 pointer to allow for polymorphism. */
10821 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10822 rss
->info
->type
= GFC_SS_REFERENCE
;
10824 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10825 /* Associate the SS with the loop. */
10826 gfc_add_ss_to_loop (&loop
, lss
);
10827 gfc_add_ss_to_loop (&loop
, rss
);
10829 /* Calculate the bounds of the scalarization. */
10830 gfc_conv_ss_startstride (&loop
);
10831 /* Enable loop reversal. */
10832 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10833 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10834 /* Resolve any data dependencies in the statement. */
10836 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10837 /* Setup the scalarizing loops. */
10838 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10840 /* Setup the gfc_se structures. */
10841 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10842 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10845 gfc_mark_ss_chain_used (rss
, 1);
10846 if (loop
.temp_ss
== NULL
)
10849 gfc_mark_ss_chain_used (lss
, 1);
10853 lse
.ss
= loop
.temp_ss
;
10854 gfc_mark_ss_chain_used (lss
, 3);
10855 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10858 /* Allow the scalarizer to workshare array assignments. */
10859 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10860 == OMPWS_WORKSHARE_FLAG
10861 && loop
.temp_ss
== NULL
)
10863 maybe_workshare
= true;
10864 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10867 /* Start the scalarized loop body. */
10868 gfc_start_scalarized_body (&loop
, &body
);
10871 gfc_init_block (&body
);
10873 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10875 /* Translate the expression. */
10876 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10877 && lhs_caf_attr
.codimension
;
10878 gfc_conv_expr (&rse
, expr2
);
10880 /* Deal with the case of a scalar class function assigned to a derived type. */
10881 if (gfc_is_alloc_class_scalar_function (expr2
)
10882 && expr1
->ts
.type
== BT_DERIVED
)
10884 rse
.expr
= gfc_class_data_get (rse
.expr
);
10885 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10888 /* Stabilize a string length for temporaries. */
10889 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10890 && !(VAR_P (rse
.string_length
)
10891 || TREE_CODE (rse
.string_length
) == PARM_DECL
10892 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10893 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10894 else if (expr2
->ts
.type
== BT_CHARACTER
)
10896 if (expr1
->ts
.deferred
10897 && gfc_expr_attr (expr1
).allocatable
10898 && gfc_check_dependency (expr1
, expr2
, true))
10899 rse
.string_length
=
10900 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
10901 string_length
= rse
.string_length
;
10904 string_length
= NULL_TREE
;
10908 gfc_conv_tmp_array_ref (&lse
);
10909 if (expr2
->ts
.type
== BT_CHARACTER
)
10910 lse
.string_length
= string_length
;
10914 gfc_conv_expr (&lse
, expr1
);
10915 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10917 && gfc_expr_attr (expr1
).allocatable
10924 tmp
= INDIRECT_REF_P (lse
.expr
)
10925 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10927 /* We should only get array references here. */
10928 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10929 || TREE_CODE (tmp
) == ARRAY_REF
);
10931 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10932 or the array itself(ARRAY_REF). */
10933 tmp
= TREE_OPERAND (tmp
, 0);
10935 /* Provide the address of the array. */
10936 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10937 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10939 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10940 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10941 msg
= _("Assignment of scalar to unallocated array");
10942 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10943 &expr1
->where
, msg
);
10946 /* Deallocate the lhs parameterized components if required. */
10947 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10948 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10950 if (expr1
->ts
.type
== BT_DERIVED
10951 && expr1
->ts
.u
.derived
10952 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10954 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10956 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10958 else if (expr1
->ts
.type
== BT_CLASS
10959 && CLASS_DATA (expr1
)->ts
.u
.derived
10960 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10962 tmp
= gfc_class_data_get (lse
.expr
);
10963 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10965 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10970 /* Assignments of scalar derived types with allocatable components
10971 to arrays must be done with a deep copy and the rhs temporary
10972 must have its components deallocated afterwards. */
10973 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10974 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10975 && !gfc_expr_is_variable (expr2
)
10976 && expr1
->rank
&& !expr2
->rank
);
10977 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10979 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10980 && gfc_is_alloc_class_scalar_function (expr2
));
10981 if (scalar_to_array
&& dealloc
)
10983 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10984 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10987 /* When assigning a character function result to a deferred-length variable,
10988 the function call must happen before the (re)allocation of the lhs -
10989 otherwise the character length of the result is not known.
10990 NOTE 1: This relies on having the exact dependence of the length type
10991 parameter available to the caller; gfortran saves it in the .mod files.
10992 NOTE 2: Vector array references generate an index temporary that must
10993 not go outside the loop. Otherwise, variables should not generate
10995 NOTE 3: The concatenation operation generates a temporary pointer,
10996 whose allocation must go to the innermost loop.
10997 NOTE 4: Elemental functions may generate a temporary, too. */
10998 if (flag_realloc_lhs
10999 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
11000 && !(lss
!= gfc_ss_terminator
11001 && rss
!= gfc_ss_terminator
11002 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
11003 || (expr2
->expr_type
== EXPR_FUNCTION
11004 && expr2
->value
.function
.esym
!= NULL
11005 && expr2
->value
.function
.esym
->attr
.elemental
)
11006 || (expr2
->expr_type
== EXPR_FUNCTION
11007 && expr2
->value
.function
.isym
!= NULL
11008 && expr2
->value
.function
.isym
->elemental
)
11009 || (expr2
->expr_type
== EXPR_OP
11010 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
11011 gfc_add_block_to_block (&block
, &rse
.pre
);
11013 /* Nullify the allocatable components corresponding to those of the lhs
11014 derived type, so that the finalization of the function result does not
11015 affect the lhs of the assignment. Prepend is used to ensure that the
11016 nullification occurs before the call to the finalizer. In the case of
11017 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11018 as part of the deep copy. */
11019 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11020 && (gfc_is_class_array_function (expr2
)
11021 || gfc_is_alloc_class_scalar_function (expr2
)))
11023 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11024 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11025 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11026 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11031 if (is_poly_assign
)
11032 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11033 use_vptr_copy
|| (lhs_attr
.allocatable
11034 && !lhs_attr
.dimension
),
11035 flag_realloc_lhs
&& !lhs_attr
.pointer
);
11036 else if (flag_coarray
== GFC_FCOARRAY_LIB
11037 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11038 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11039 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11041 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11042 allocatable component, because those need to be accessed via the
11043 caf-runtime. No need to check for coindexes here, because resolve
11044 has rewritten those already. */
11046 gfc_actual_arglist a1
, a2
;
11047 /* Clear the structures to prevent accessing garbage. */
11048 memset (&code
, '\0', sizeof (gfc_code
));
11049 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11050 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11055 code
.ext
.actual
= &a1
;
11056 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11057 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11059 else if (!is_poly_assign
&& expr2
->must_finalize
11060 && expr1
->ts
.type
== BT_CLASS
11061 && expr2
->ts
.type
== BT_CLASS
)
11063 /* This case comes about when the scalarizer provides array element
11064 references. Use the vptr copy function, since this does a deep
11065 copy of allocatable components, without which the finalizer call */
11066 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11067 if (tmp
!= NULL_TREE
)
11069 tree fcn
= gfc_vptr_copy_get (tmp
);
11070 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11071 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11072 tmp
= build_call_expr_loc (input_location
,
11074 gfc_build_addr_expr (NULL
, rse
.expr
),
11075 gfc_build_addr_expr (NULL
, lse
.expr
));
11079 /* If nothing else works, do it the old fashioned way! */
11080 if (tmp
== NULL_TREE
)
11081 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11082 gfc_expr_is_variable (expr2
)
11084 || expr2
->expr_type
== EXPR_ARRAY
,
11085 !(l_is_temp
|| init_flag
) && dealloc
,
11086 expr1
->symtree
->n
.sym
->attr
.codimension
);
11088 /* Add the pre blocks to the body. */
11089 gfc_add_block_to_block (&body
, &rse
.pre
);
11090 gfc_add_block_to_block (&body
, &lse
.pre
);
11091 gfc_add_expr_to_block (&body
, tmp
);
11092 /* Add the post blocks to the body. */
11093 gfc_add_block_to_block (&body
, &rse
.post
);
11094 gfc_add_block_to_block (&body
, &lse
.post
);
11096 if (lss
== gfc_ss_terminator
)
11098 /* F2003: Add the code for reallocation on assignment. */
11099 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11100 && !is_poly_assign
)
11101 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11104 /* Use the scalar assignment as is. */
11105 gfc_add_block_to_block (&block
, &body
);
11109 gcc_assert (lse
.ss
== gfc_ss_terminator
11110 && rse
.ss
== gfc_ss_terminator
);
11114 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11116 /* We need to copy the temporary to the actual lhs. */
11117 gfc_init_se (&lse
, NULL
);
11118 gfc_init_se (&rse
, NULL
);
11119 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11120 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11122 rse
.ss
= loop
.temp_ss
;
11125 gfc_conv_tmp_array_ref (&rse
);
11126 gfc_conv_expr (&lse
, expr1
);
11128 gcc_assert (lse
.ss
== gfc_ss_terminator
11129 && rse
.ss
== gfc_ss_terminator
);
11131 if (expr2
->ts
.type
== BT_CHARACTER
)
11132 rse
.string_length
= string_length
;
11134 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11136 gfc_add_expr_to_block (&body
, tmp
);
11139 /* F2003: Allocate or reallocate lhs of allocatable array. */
11140 if (flag_realloc_lhs
11141 && gfc_is_reallocatable_lhs (expr1
)
11143 && !is_runtime_conformable (expr1
, expr2
))
11145 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11146 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11147 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11148 if (tmp
!= NULL_TREE
)
11149 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11152 if (maybe_workshare
)
11153 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11155 /* Generate the copying loops. */
11156 gfc_trans_scalarizing_loops (&loop
, &body
);
11158 /* Wrap the whole thing up. */
11159 gfc_add_block_to_block (&block
, &loop
.pre
);
11160 gfc_add_block_to_block (&block
, &loop
.post
);
11162 gfc_cleanup_loop (&loop
);
11165 return gfc_finish_block (&block
);
11169 /* Check whether EXPR is a copyable array. */
11172 copyable_array_p (gfc_expr
* expr
)
11174 if (expr
->expr_type
!= EXPR_VARIABLE
)
11177 /* First check it's an array. */
11178 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11181 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11184 /* Next check that it's of a simple enough type. */
11185 switch (expr
->ts
.type
)
11197 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
11206 /* Translate an assignment. */
11209 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11210 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11214 /* Special case a single function returning an array. */
11215 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
11217 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
11222 /* Special case assigning an array to zero. */
11223 if (copyable_array_p (expr1
)
11224 && is_zero_initializer_p (expr2
))
11226 tmp
= gfc_trans_zero_assign (expr1
);
11231 /* Special case copying one array to another. */
11232 if (copyable_array_p (expr1
)
11233 && copyable_array_p (expr2
)
11234 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
11235 && !gfc_check_dependency (expr1
, expr2
, 0))
11237 tmp
= gfc_trans_array_copy (expr1
, expr2
);
11242 /* Special case initializing an array from a constant array constructor. */
11243 if (copyable_array_p (expr1
)
11244 && expr2
->expr_type
== EXPR_ARRAY
11245 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
11247 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
11252 if (UNLIMITED_POLY (expr1
) && expr1
->rank
11253 && expr2
->ts
.type
!= BT_CLASS
)
11254 use_vptr_copy
= true;
11256 /* Fallback to the scalarizer to generate explicit loops. */
11257 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
11258 use_vptr_copy
, may_alias
);
11262 gfc_trans_init_assign (gfc_code
* code
)
11264 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
11268 gfc_trans_assign (gfc_code
* code
)
11270 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);