1 /* Expression translation
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 tree desc
, type
, etype
;
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 etype
= TREE_TYPE (scalar
);
73 desc
= gfc_create_var (type
, "desc");
74 DECL_ARTIFICIAL (desc
) = 1;
76 if (CONSTANT_CLASS_P (scalar
))
79 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
80 gfc_add_modify (&se
->pre
, tmp
, scalar
);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
84 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
85 else if (TREE_TYPE (etype
) && TREE_CODE (TREE_TYPE (etype
)) == ARRAY_TYPE
)
86 etype
= TREE_TYPE (etype
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype_rank_type (0, etype
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
107 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
108 bool is_coarray
= sym
->attr
.codimension
;
109 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
110 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
114 if (ref
->type
== REF_COMPONENT
115 && (ref
->u
.c
.component
->attr
.allocatable
116 || ref
->u
.c
.component
->attr
.pointer
)
117 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
122 if (last_caf_ref
== NULL
)
125 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
127 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
128 if (comp
== NULL_TREE
&& comp_ref
)
130 gfc_init_se (&se
, outerse
);
131 gfc_free_ref_list (last_caf_ref
->next
);
132 last_caf_ref
->next
= NULL
;
133 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
134 se
.want_pointer
= comp_ref
;
135 gfc_conv_expr (&se
, caf_expr
);
136 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
138 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
139 se
.expr
= TREE_OPERAND (se
.expr
, 0);
140 gfc_free_expr (caf_expr
);
143 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
146 caf
= gfc_conv_descriptor_token (se
.expr
);
147 return gfc_build_addr_expr (NULL_TREE
, caf
);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
172 vec
<constructor_elt
, va_gc
> *init
= NULL
;
174 field
= TYPE_FIELDS (TREE_TYPE (decl
));
175 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
178 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
179 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
181 return build_constructor (TREE_TYPE (decl
), init
);
186 gfc_class_data_get (tree decl
)
189 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
190 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
191 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
193 return fold_build3_loc (input_location
, COMPONENT_REF
,
194 TREE_TYPE (data
), decl
, data
,
200 gfc_class_vptr_get (tree decl
)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
207 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
208 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
209 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
210 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
212 return fold_build3_loc (input_location
, COMPONENT_REF
,
213 TREE_TYPE (vptr
), decl
, vptr
,
219 gfc_class_len_get (tree decl
)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
226 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
227 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
228 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
229 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
231 return fold_build3_loc (input_location
, COMPONENT_REF
,
232 TREE_TYPE (len
), decl
, len
,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl
)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
248 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
249 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
250 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
251 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
253 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
254 TREE_TYPE (len
), decl
, len
,
256 : build_zero_cst (gfc_charlen_type_node
);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr
, int fieldno
)
266 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
267 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
269 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
270 TREE_TYPE (field
), vptr
, field
,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl
, int fieldno
)
283 vptr
= gfc_class_vptr_get (decl
);
284 return vptr_field_get (vptr
, fieldno
);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
303 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
304 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
305 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
306 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
307 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl
)
317 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
318 /* Always return size as an array index type. */
319 size
= fold_convert (gfc_array_index_type
, size
);
325 gfc_vptr_size_get (tree vptr
)
328 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
329 /* Always return size as an array index type. */
330 size
= fold_convert (gfc_array_index_type
, size
);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
, bool is_mold
)
358 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
360 /* Find the last class reference. */
363 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
365 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
380 if (ref
->next
== NULL
)
384 /* Remove and store all subsequent references after the
388 tail
= class_ref
->next
;
389 class_ref
->next
= NULL
;
391 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
398 base_expr
= gfc_expr_to_initialize (e
);
400 base_expr
= gfc_copy_expr (e
);
402 /* Restore the original tail expression. */
405 gfc_free_ref_list (class_ref
->next
);
406 class_ref
->next
= tail
;
408 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
410 gfc_free_ref_list (e
->ref
);
417 /* Reset the vptr to the declared type, e.g. after deallocation. */
420 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
427 /* Evaluate the expression and obtain the vptr from it. */
428 gfc_init_se (&se
, NULL
);
430 gfc_conv_expr_descriptor (&se
, e
);
432 gfc_conv_expr (&se
, e
);
433 gfc_add_block_to_block (block
, &se
.pre
);
434 vptr
= gfc_get_vptr_from_expr (se
.expr
);
436 /* If a vptr is not found, we can do nothing more. */
437 if (vptr
== NULL_TREE
)
440 if (UNLIMITED_POLY (e
))
441 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
444 /* Return the vptr to the address of the declared type. */
445 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
446 vtable
= vtab
->backend_decl
;
447 if (vtable
== NULL_TREE
)
448 vtable
= gfc_get_symbol_decl (vtab
);
449 vtable
= gfc_build_addr_expr (NULL
, vtable
);
450 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
451 gfc_add_modify (block
, vptr
, vtable
);
456 /* Reset the len for unlimited polymorphic objects. */
459 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
463 e
= gfc_find_and_cut_at_last_class_ref (expr
);
466 gfc_add_len_component (e
);
467 gfc_init_se (&se_len
, NULL
);
468 gfc_conv_expr (&se_len
, e
);
469 gfc_add_modify (block
, se_len
.expr
,
470 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
475 /* Obtain the last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_class_from_expr (tree expr
)
484 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
486 type
= TREE_TYPE (tmp
);
489 if (GFC_CLASS_TYPE_P (type
))
491 if (type
!= TYPE_CANONICAL (type
))
492 type
= TYPE_CANONICAL (type
);
496 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
500 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
501 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
510 /* Obtain the vptr of the last class reference in an expression.
511 Return NULL_TREE if no class reference is found. */
514 gfc_get_vptr_from_expr (tree expr
)
518 tmp
= gfc_get_class_from_expr (expr
);
520 if (tmp
!= NULL_TREE
)
521 return gfc_class_vptr_get (tmp
);
528 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
531 tree tmp
, tmp2
, type
;
533 gfc_conv_descriptor_data_set (block
, lhs_desc
,
534 gfc_conv_descriptor_data_get (rhs_desc
));
535 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
536 gfc_conv_descriptor_offset_get (rhs_desc
));
538 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
539 gfc_conv_descriptor_dtype (rhs_desc
));
541 /* Assign the dimension as range-ref. */
542 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
543 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
545 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
546 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
547 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
548 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
549 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
550 gfc_add_modify (block
, tmp
, tmp2
);
554 /* Takes a derived type expression and returns the address of a temporary
555 class object of the 'declared' type. If vptr is not NULL, this is
556 used for the temporary class object.
557 optional_alloc_ptr is false when the dummy is neither allocatable
558 nor a pointer; that's only relevant for the optional handling. */
560 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
561 gfc_typespec class_ts
, tree vptr
, bool optional
,
562 bool optional_alloc_ptr
)
565 tree cond_optional
= NULL_TREE
;
572 /* The derived type needs to be converted to a temporary
574 tmp
= gfc_typenode_for_spec (&class_ts
);
575 var
= gfc_create_var (tmp
, "class");
578 ctree
= gfc_class_vptr_get (var
);
580 if (vptr
!= NULL_TREE
)
582 /* Use the dynamic vptr. */
587 /* In this case the vtab corresponds to the derived type and the
588 vptr must point to it. */
589 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
591 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
593 gfc_add_modify (&parmse
->pre
, ctree
,
594 fold_convert (TREE_TYPE (ctree
), tmp
));
596 /* Now set the data field. */
597 ctree
= gfc_class_data_get (var
);
600 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
602 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
604 /* If there is a ready made pointer to a derived type, use it
605 rather than evaluating the expression again. */
606 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
607 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
609 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
611 /* For an array reference in an elemental procedure call we need
612 to retain the ss to provide the scalarized array reference. */
613 gfc_conv_expr_reference (parmse
, e
);
614 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
616 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
618 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
619 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
623 ss
= gfc_walk_expr (e
);
624 if (ss
== gfc_ss_terminator
)
627 gfc_conv_expr_reference (parmse
, e
);
629 /* Scalar to an assumed-rank array. */
630 if (class_ts
.u
.derived
->components
->as
)
633 type
= get_scalar_to_descriptor_type (parmse
->expr
,
635 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
636 gfc_get_dtype (type
));
638 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
639 TREE_TYPE (parmse
->expr
),
640 cond_optional
, parmse
->expr
,
641 fold_convert (TREE_TYPE (parmse
->expr
),
643 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
647 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
649 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
651 fold_convert (TREE_TYPE (tmp
),
653 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
659 gfc_init_block (&block
);
663 parmse
->use_offset
= 1;
664 gfc_conv_expr_descriptor (parmse
, e
);
666 /* Detect any array references with vector subscripts. */
667 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
668 if (ref
->type
== REF_ARRAY
669 && ref
->u
.ar
.type
!= AR_ELEMENT
670 && ref
->u
.ar
.type
!= AR_FULL
)
672 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
673 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
675 if (dim
< ref
->u
.ar
.dimen
)
679 /* Array references with vector subscripts and non-variable expressions
680 need be converted to a one-based descriptor. */
681 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
683 for (dim
= 0; dim
< e
->rank
; ++dim
)
684 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
688 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
690 gcc_assert (class_ts
.u
.derived
->components
->as
->type
692 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
696 if (gfc_expr_attr (e
).codimension
)
697 parmse
->expr
= fold_build1_loc (input_location
,
701 gfc_add_modify (&block
, ctree
, parmse
->expr
);
706 tmp
= gfc_finish_block (&block
);
708 gfc_init_block (&block
);
709 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
711 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
712 gfc_finish_block (&block
));
713 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
716 gfc_add_block_to_block (&parmse
->pre
, &block
);
720 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
721 && class_ts
.u
.derived
->components
->ts
.u
.derived
722 ->attr
.unlimited_polymorphic
)
724 /* Take care about initializing the _len component correctly. */
725 ctree
= gfc_class_len_get (var
);
726 if (UNLIMITED_POLY (e
))
731 len
= gfc_copy_expr (e
);
732 gfc_add_len_component (len
);
733 gfc_init_se (&se
, NULL
);
734 gfc_conv_expr (&se
, len
);
736 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
737 cond_optional
, se
.expr
,
738 fold_convert (TREE_TYPE (se
.expr
),
744 tmp
= integer_zero_node
;
745 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
748 /* Pass the address of the class object. */
749 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
751 if (optional
&& optional_alloc_ptr
)
752 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
753 TREE_TYPE (parmse
->expr
),
754 cond_optional
, parmse
->expr
,
755 fold_convert (TREE_TYPE (parmse
->expr
),
760 /* Create a new class container, which is required as scalar coarrays
761 have an array descriptor while normal scalars haven't. Optionally,
762 NULL pointer checks are added if the argument is OPTIONAL. */
765 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
766 gfc_typespec class_ts
, bool optional
)
768 tree var
, ctree
, tmp
;
773 gfc_init_block (&block
);
776 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
778 if (ref
->type
== REF_COMPONENT
779 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
783 if (class_ref
== NULL
784 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
785 tmp
= e
->symtree
->n
.sym
->backend_decl
;
788 /* Remove everything after the last class reference, convert the
789 expression and then recover its tailend once more. */
791 ref
= class_ref
->next
;
792 class_ref
->next
= NULL
;
793 gfc_init_se (&tmpse
, NULL
);
794 gfc_conv_expr (&tmpse
, e
);
795 class_ref
->next
= ref
;
799 var
= gfc_typenode_for_spec (&class_ts
);
800 var
= gfc_create_var (var
, "class");
802 ctree
= gfc_class_vptr_get (var
);
803 gfc_add_modify (&block
, ctree
,
804 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
806 ctree
= gfc_class_data_get (var
);
807 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
808 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
810 /* Pass the address of the class object. */
811 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
815 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
818 tmp
= gfc_finish_block (&block
);
820 gfc_init_block (&block
);
821 tmp2
= gfc_class_data_get (var
);
822 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
824 tmp2
= gfc_finish_block (&block
);
826 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
828 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
831 gfc_add_block_to_block (&parmse
->pre
, &block
);
835 /* Takes an intrinsic type expression and returns the address of a temporary
836 class object of the 'declared' type. */
838 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
839 gfc_typespec class_ts
)
847 /* The intrinsic type needs to be converted to a temporary
849 tmp
= gfc_typenode_for_spec (&class_ts
);
850 var
= gfc_create_var (tmp
, "class");
853 ctree
= gfc_class_vptr_get (var
);
855 vtab
= gfc_find_vtab (&e
->ts
);
857 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
858 gfc_add_modify (&parmse
->pre
, ctree
,
859 fold_convert (TREE_TYPE (ctree
), tmp
));
861 /* Now set the data field. */
862 ctree
= gfc_class_data_get (var
);
863 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
865 /* For an array reference in an elemental procedure call we need
866 to retain the ss to provide the scalarized array reference. */
867 gfc_conv_expr_reference (parmse
, e
);
868 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
869 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
873 ss
= gfc_walk_expr (e
);
874 if (ss
== gfc_ss_terminator
)
877 gfc_conv_expr_reference (parmse
, e
);
878 if (class_ts
.u
.derived
->components
->as
879 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
881 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
883 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
884 TREE_TYPE (ctree
), tmp
);
887 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
888 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
893 parmse
->use_offset
= 1;
894 gfc_conv_expr_descriptor (parmse
, e
);
895 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
897 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
898 TREE_TYPE (ctree
), parmse
->expr
);
899 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
902 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
906 gcc_assert (class_ts
.type
== BT_CLASS
);
907 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
908 && class_ts
.u
.derived
->components
->ts
.u
.derived
909 ->attr
.unlimited_polymorphic
)
911 ctree
= gfc_class_len_get (var
);
912 /* When the actual arg is a char array, then set the _len component of the
913 unlimited polymorphic entity to the length of the string. */
914 if (e
->ts
.type
== BT_CHARACTER
)
916 /* Start with parmse->string_length because this seems to be set to a
917 correct value more often. */
918 if (parmse
->string_length
)
919 tmp
= parmse
->string_length
;
920 /* When the string_length is not yet set, then try the backend_decl of
922 else if (e
->ts
.u
.cl
->backend_decl
)
923 tmp
= e
->ts
.u
.cl
->backend_decl
;
924 /* If both of the above approaches fail, then try to generate an
925 expression from the input, which is only feasible currently, when the
926 expression can be evaluated to a constant one. */
929 /* Try to simplify the expression. */
930 gfc_simplify_expr (e
, 0);
931 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
933 /* Amazingly all data is present to compute the length of a
934 constant string, but the expression is not yet there. */
935 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
936 gfc_charlen_int_kind
,
938 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
939 e
->value
.character
.length
);
940 gfc_conv_const_charlen (e
->ts
.u
.cl
);
941 e
->ts
.u
.cl
->resolved
= 1;
942 tmp
= e
->ts
.u
.cl
->backend_decl
;
946 gfc_error ("Cannot compute the length of the char array "
947 "at %L.", &e
->where
);
952 tmp
= integer_zero_node
;
954 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
956 else if (class_ts
.type
== BT_CLASS
957 && class_ts
.u
.derived
->components
958 && class_ts
.u
.derived
->components
->ts
.u
959 .derived
->attr
.unlimited_polymorphic
)
961 ctree
= gfc_class_len_get (var
);
962 gfc_add_modify (&parmse
->pre
, ctree
,
963 fold_convert (TREE_TYPE (ctree
),
966 /* Pass the address of the class object. */
967 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
971 /* Takes a scalarized class array expression and returns the
972 address of a temporary scalar class object of the 'declared'
974 OOP-TODO: This could be improved by adding code that branched on
975 the dynamic type being the same as the declared type. In this case
976 the original class expression can be passed directly.
977 optional_alloc_ptr is false when the dummy is neither allocatable
978 nor a pointer; that's relevant for the optional handling.
979 Set copyback to true if class container's _data and _vtab pointers
980 might get modified. */
983 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
984 bool elemental
, bool copyback
, bool optional
,
985 bool optional_alloc_ptr
)
991 tree cond
= NULL_TREE
;
992 tree slen
= NULL_TREE
;
996 bool full_array
= false;
998 gfc_init_block (&block
);
1001 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1003 if (ref
->type
== REF_COMPONENT
1004 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1007 if (ref
->next
== NULL
)
1011 if ((ref
== NULL
|| class_ref
== ref
)
1012 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1013 && (!class_ts
.u
.derived
->components
->as
1014 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1017 /* Test for FULL_ARRAY. */
1018 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1019 && gfc_expr_attr (e
).dimension
)
1022 gfc_is_class_array_ref (e
, &full_array
);
1024 /* The derived type needs to be converted to a temporary
1026 tmp
= gfc_typenode_for_spec (&class_ts
);
1027 var
= gfc_create_var (tmp
, "class");
1030 ctree
= gfc_class_data_get (var
);
1031 if (class_ts
.u
.derived
->components
->as
1032 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1036 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1038 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1039 gfc_get_dtype (type
));
1041 tmp
= gfc_class_data_get (parmse
->expr
);
1042 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1043 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1045 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1048 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1052 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1053 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1054 TREE_TYPE (ctree
), parmse
->expr
);
1055 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1058 /* Return the data component, except in the case of scalarized array
1059 references, where nullification of the cannot occur and so there
1061 if (!elemental
&& full_array
&& copyback
)
1063 if (class_ts
.u
.derived
->components
->as
1064 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1067 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1068 gfc_conv_descriptor_data_get (ctree
));
1070 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1073 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1077 ctree
= gfc_class_vptr_get (var
);
1079 /* The vptr is the second field of the actual argument.
1080 First we have to find the corresponding class reference. */
1083 if (gfc_is_class_array_function (e
)
1084 && parmse
->class_vptr
!= NULL_TREE
)
1085 tmp
= parmse
->class_vptr
;
1086 else if (class_ref
== NULL
1087 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1089 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1091 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1092 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1094 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1095 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1097 slen
= build_zero_cst (size_type_node
);
1101 /* Remove everything after the last class reference, convert the
1102 expression and then recover its tailend once more. */
1104 ref
= class_ref
->next
;
1105 class_ref
->next
= NULL
;
1106 gfc_init_se (&tmpse
, NULL
);
1107 gfc_conv_expr (&tmpse
, e
);
1108 class_ref
->next
= ref
;
1110 slen
= tmpse
.string_length
;
1113 gcc_assert (tmp
!= NULL_TREE
);
1115 /* Dereference if needs be. */
1116 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1117 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1119 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1120 vptr
= gfc_class_vptr_get (tmp
);
1124 gfc_add_modify (&block
, ctree
,
1125 fold_convert (TREE_TYPE (ctree
), vptr
));
1127 /* Return the vptr component, except in the case of scalarized array
1128 references, where the dynamic type cannot change. */
1129 if (!elemental
&& full_array
&& copyback
)
1130 gfc_add_modify (&parmse
->post
, vptr
,
1131 fold_convert (TREE_TYPE (vptr
), ctree
));
1133 /* For unlimited polymorphic objects also set the _len component. */
1134 if (class_ts
.type
== BT_CLASS
1135 && class_ts
.u
.derived
->components
1136 && class_ts
.u
.derived
->components
->ts
.u
1137 .derived
->attr
.unlimited_polymorphic
)
1139 ctree
= gfc_class_len_get (var
);
1140 if (UNLIMITED_POLY (e
))
1141 tmp
= gfc_class_len_get (tmp
);
1142 else if (e
->ts
.type
== BT_CHARACTER
)
1144 gcc_assert (slen
!= NULL_TREE
);
1148 tmp
= build_zero_cst (size_type_node
);
1149 gfc_add_modify (&parmse
->pre
, ctree
,
1150 fold_convert (TREE_TYPE (ctree
), tmp
));
1152 /* Return the len component, except in the case of scalarized array
1153 references, where the dynamic type cannot change. */
1154 if (!elemental
&& full_array
&& copyback
1155 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1156 gfc_add_modify (&parmse
->post
, tmp
,
1157 fold_convert (TREE_TYPE (tmp
), ctree
));
1164 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1165 /* parmse->pre may contain some preparatory instructions for the
1166 temporary array descriptor. Those may only be executed when the
1167 optional argument is set, therefore add parmse->pre's instructions
1168 to block, which is later guarded by an if (optional_arg_given). */
1169 gfc_add_block_to_block (&parmse
->pre
, &block
);
1170 block
.head
= parmse
->pre
.head
;
1171 parmse
->pre
.head
= NULL_TREE
;
1172 tmp
= gfc_finish_block (&block
);
1174 if (optional_alloc_ptr
)
1175 tmp2
= build_empty_stmt (input_location
);
1178 gfc_init_block (&block
);
1180 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1181 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1182 null_pointer_node
));
1183 tmp2
= gfc_finish_block (&block
);
1186 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1188 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1191 gfc_add_block_to_block (&parmse
->pre
, &block
);
1193 /* Pass the address of the class object. */
1194 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1196 if (optional
&& optional_alloc_ptr
)
1197 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1198 TREE_TYPE (parmse
->expr
),
1200 fold_convert (TREE_TYPE (parmse
->expr
),
1201 null_pointer_node
));
1205 /* Given a class array declaration and an index, returns the address
1206 of the referenced element. */
1209 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1212 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1214 data
= data_comp
!= NULL_TREE
? data_comp
:
1215 gfc_class_data_get (class_decl
);
1216 size
= gfc_class_vtab_size_get (class_decl
);
1220 tmp
= fold_convert (gfc_array_index_type
,
1221 gfc_class_len_get (class_decl
));
1222 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1223 gfc_array_index_type
, size
, tmp
);
1224 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1225 logical_type_node
, tmp
,
1226 build_zero_cst (TREE_TYPE (tmp
)));
1227 size
= fold_build3_loc (input_location
, COND_EXPR
,
1228 gfc_array_index_type
, tmp
, ctmp
, size
);
1231 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1232 gfc_array_index_type
,
1235 data
= gfc_conv_descriptor_data_get (data
);
1236 ptr
= fold_convert (pvoid_type_node
, data
);
1237 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1238 return fold_convert (TREE_TYPE (data
), ptr
);
1242 /* Copies one class expression to another, assuming that if either
1243 'to' or 'from' are arrays they are packed. Should 'from' be
1244 NULL_TREE, the initialization expression for 'to' is used, assuming
1245 that the _vptr is set. */
1248 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1258 vec
<tree
, va_gc
> *args
;
1263 bool is_from_desc
= false, is_to_class
= false;
1266 /* To prevent warnings on uninitialized variables. */
1267 from_len
= to_len
= NULL_TREE
;
1269 if (from
!= NULL_TREE
)
1270 fcn
= gfc_class_vtab_copy_get (from
);
1272 fcn
= gfc_class_vtab_copy_get (to
);
1274 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1276 if (from
!= NULL_TREE
)
1278 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1282 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1286 /* Check that from is a class. When the class is part of a coarray,
1287 then from is a common pointer and is to be used as is. */
1288 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1289 ? build_fold_indirect_ref (from
) : from
;
1291 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1292 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1293 ? gfc_class_data_get (from
) : from
;
1294 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1298 from_data
= gfc_class_vtab_def_init_get (to
);
1302 if (from
!= NULL_TREE
&& unlimited
)
1303 from_len
= gfc_class_len_or_zero_get (from
);
1305 from_len
= build_zero_cst (size_type_node
);
1308 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1311 to_data
= gfc_class_data_get (to
);
1313 to_len
= gfc_class_len_get (to
);
1316 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1319 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1321 stmtblock_t loopbody
;
1325 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1327 gfc_init_block (&body
);
1328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1329 gfc_array_index_type
, nelems
,
1330 gfc_index_one_node
);
1331 nelems
= gfc_evaluate_now (tmp
, &body
);
1332 index
= gfc_create_var (gfc_array_index_type
, "S");
1336 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1338 vec_safe_push (args
, from_ref
);
1341 vec_safe_push (args
, from_data
);
1344 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1347 tmp
= gfc_conv_array_data (to
);
1348 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1349 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1350 gfc_build_array_ref (tmp
, index
, to
));
1352 vec_safe_push (args
, to_ref
);
1354 /* Add bounds check. */
1355 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1358 const char *name
= "<<unknown>>";
1362 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1364 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1365 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1366 logical_type_node
, from_len
, orig_nelems
);
1367 msg
= xasprintf ("Array bound mismatch for dimension %d "
1368 "of array '%s' (%%ld/%%ld)",
1371 gfc_trans_runtime_check (true, false, tmp
, &body
,
1372 &gfc_current_locus
, msg
,
1373 fold_convert (long_integer_type_node
, orig_nelems
),
1374 fold_convert (long_integer_type_node
, from_len
));
1379 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody
);
1383 gfc_add_expr_to_block (&loopbody
, tmp
);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop
);
1388 loop
.from
[0] = gfc_index_zero_node
;
1389 loop
.loopvar
[0] = index
;
1390 loop
.to
[0] = nelems
;
1391 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1392 gfc_init_block (&ifbody
);
1393 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1394 stdcopy
= gfc_finish_block (&ifbody
);
1395 /* In initialization mode from_len is a constant zero. */
1396 if (unlimited
&& !integer_zerop (from_len
))
1398 vec_safe_push (args
, from_len
);
1399 vec_safe_push (args
, to_len
);
1400 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1401 /* Build the body of the loop. */
1402 gfc_init_block (&loopbody
);
1403 gfc_add_expr_to_block (&loopbody
, tmp
);
1405 /* Build the loop and return. */
1406 gfc_init_loopinfo (&loop
);
1408 loop
.from
[0] = gfc_index_zero_node
;
1409 loop
.loopvar
[0] = index
;
1410 loop
.to
[0] = nelems
;
1411 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1412 gfc_init_block (&ifbody
);
1413 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1414 extcopy
= gfc_finish_block (&ifbody
);
1416 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1417 logical_type_node
, from_len
,
1418 build_zero_cst (TREE_TYPE (from_len
)));
1419 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1420 void_type_node
, tmp
, extcopy
, stdcopy
);
1421 gfc_add_expr_to_block (&body
, tmp
);
1422 tmp
= gfc_finish_block (&body
);
1426 gfc_add_expr_to_block (&body
, stdcopy
);
1427 tmp
= gfc_finish_block (&body
);
1429 gfc_cleanup_loop (&loop
);
1433 gcc_assert (!is_from_desc
);
1434 vec_safe_push (args
, from_data
);
1435 vec_safe_push (args
, to_data
);
1436 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1438 /* In initialization mode from_len is a constant zero. */
1439 if (unlimited
&& !integer_zerop (from_len
))
1441 vec_safe_push (args
, from_len
);
1442 vec_safe_push (args
, to_len
);
1443 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1444 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1445 logical_type_node
, from_len
,
1446 build_zero_cst (TREE_TYPE (from_len
)));
1447 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1448 void_type_node
, tmp
, extcopy
, stdcopy
);
1454 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1455 if (from
== NULL_TREE
)
1458 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1460 from_data
, null_pointer_node
);
1461 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1462 void_type_node
, cond
,
1463 tmp
, build_empty_stmt (input_location
));
1471 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1473 gfc_actual_arglist
*actual
;
1478 actual
= gfc_get_actual_arglist ();
1479 actual
->expr
= gfc_copy_expr (rhs
);
1480 actual
->next
= gfc_get_actual_arglist ();
1481 actual
->next
->expr
= gfc_copy_expr (lhs
);
1482 ppc
= gfc_copy_expr (obj
);
1483 gfc_add_vptr_component (ppc
);
1484 gfc_add_component_ref (ppc
, "_copy");
1485 ppc_code
= gfc_get_code (EXEC_CALL
);
1486 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1487 /* Although '_copy' is set to be elemental in class.c, it is
1488 not staying that way. Find out why, sometime.... */
1489 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1490 ppc_code
->ext
.actual
= actual
;
1491 ppc_code
->expr1
= ppc
;
1492 /* Since '_copy' is elemental, the scalarizer will take care
1493 of arrays in gfc_trans_call. */
1494 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1495 gfc_free_statements (ppc_code
);
1497 if (UNLIMITED_POLY(obj
))
1499 /* Check if rhs is non-NULL. */
1501 gfc_init_se (&src
, NULL
);
1502 gfc_conv_expr (&src
, rhs
);
1503 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1504 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1505 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1506 null_pointer_node
));
1507 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1508 build_empty_stmt (input_location
));
1514 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1515 A MEMCPY is needed to copy the full data from the default initializer
1516 of the dynamic type. */
1519 gfc_trans_class_init_assign (gfc_code
*code
)
1523 gfc_se dst
,src
,memsz
;
1524 gfc_expr
*lhs
, *rhs
, *sz
;
1526 gfc_start_block (&block
);
1528 lhs
= gfc_copy_expr (code
->expr1
);
1530 rhs
= gfc_copy_expr (code
->expr1
);
1531 gfc_add_vptr_component (rhs
);
1533 /* Make sure that the component backend_decls have been built, which
1534 will not have happened if the derived types concerned have not
1536 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1537 gfc_add_def_init_component (rhs
);
1538 /* The _def_init is always scalar. */
1541 if (code
->expr1
->ts
.type
== BT_CLASS
1542 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1544 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1545 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1546 /* Adding the array ref to the class expression results in correct
1547 indexing to the dynamic type. */
1548 gfc_add_full_array_ref (lhs
, tmparr
);
1549 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1553 /* Scalar initialization needs the _data component. */
1554 gfc_add_data_component (lhs
);
1555 sz
= gfc_copy_expr (code
->expr1
);
1556 gfc_add_vptr_component (sz
);
1557 gfc_add_size_component (sz
);
1559 gfc_init_se (&dst
, NULL
);
1560 gfc_init_se (&src
, NULL
);
1561 gfc_init_se (&memsz
, NULL
);
1562 gfc_conv_expr (&dst
, lhs
);
1563 gfc_conv_expr (&src
, rhs
);
1564 gfc_conv_expr (&memsz
, sz
);
1565 gfc_add_block_to_block (&block
, &src
.pre
);
1566 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1568 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1570 if (UNLIMITED_POLY(code
->expr1
))
1572 /* Check if _def_init is non-NULL. */
1573 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1574 logical_type_node
, src
.expr
,
1575 fold_convert (TREE_TYPE (src
.expr
),
1576 null_pointer_node
));
1577 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1578 tmp
, build_empty_stmt (input_location
));
1582 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1583 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1585 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1586 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1588 build_empty_stmt (input_location
));
1591 gfc_add_expr_to_block (&block
, tmp
);
1593 return gfc_finish_block (&block
);
1597 /* End of prototype trans-class.c */
1601 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1603 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1604 gfc_warning (OPT_Wrealloc_lhs
,
1605 "Code for reallocating the allocatable array at %L will "
1607 else if (warn_realloc_lhs_all
)
1608 gfc_warning (OPT_Wrealloc_lhs_all
,
1609 "Code for reallocating the allocatable variable at %L "
1610 "will be added", where
);
1614 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1617 /* Copy the scalarization loop variables. */
1620 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1623 dest
->loop
= src
->loop
;
1627 /* Initialize a simple expression holder.
1629 Care must be taken when multiple se are created with the same parent.
1630 The child se must be kept in sync. The easiest way is to delay creation
1631 of a child se until after after the previous se has been translated. */
1634 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1636 memset (se
, 0, sizeof (gfc_se
));
1637 gfc_init_block (&se
->pre
);
1638 gfc_init_block (&se
->post
);
1640 se
->parent
= parent
;
1643 gfc_copy_se_loopvars (se
, parent
);
1647 /* Advances to the next SS in the chain. Use this rather than setting
1648 se->ss = se->ss->next because all the parents needs to be kept in sync.
1652 gfc_advance_se_ss_chain (gfc_se
* se
)
1657 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1660 /* Walk down the parent chain. */
1663 /* Simple consistency check. */
1664 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1665 || p
->parent
->ss
->nested_ss
== p
->ss
);
1667 /* If we were in a nested loop, the next scalarized expression can be
1668 on the parent ss' next pointer. Thus we should not take the next
1669 pointer blindly, but rather go up one nest level as long as next
1670 is the end of chain. */
1672 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1682 /* Ensures the result of the expression as either a temporary variable
1683 or a constant so that it can be used repeatedly. */
1686 gfc_make_safe_expr (gfc_se
* se
)
1690 if (CONSTANT_CLASS_P (se
->expr
))
1693 /* We need a temporary for this result. */
1694 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1695 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1700 /* Return an expression which determines if a dummy parameter is present.
1701 Also used for arguments to procedures with multiple entry points. */
1704 gfc_conv_expr_present (gfc_symbol
* sym
)
1708 gcc_assert (sym
->attr
.dummy
);
1709 decl
= gfc_get_symbol_decl (sym
);
1711 /* Intrinsic scalars with VALUE attribute which are passed by value
1712 use a hidden argument to denote the present status. */
1713 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1714 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1715 && !sym
->attr
.dimension
)
1717 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1720 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1722 strcpy (&name
[1], sym
->name
);
1723 tree_name
= get_identifier (name
);
1725 /* Walk function argument list to find hidden arg. */
1726 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1727 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1728 if (DECL_NAME (cond
) == tree_name
1729 && DECL_ARTIFICIAL (cond
))
1736 if (TREE_CODE (decl
) != PARM_DECL
)
1738 /* Array parameters use a temporary descriptor, we want the real
1740 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1741 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1742 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1745 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1746 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1748 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1749 as actual argument to denote absent dummies. For array descriptors,
1750 we thus also need to check the array descriptor. For BT_CLASS, it
1751 can also occur for scalars and F2003 due to type->class wrapping and
1752 class->class wrapping. Note further that BT_CLASS always uses an
1753 array descriptor for arrays, also for explicit-shape/assumed-size. */
1755 if (!sym
->attr
.allocatable
1756 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1757 || (sym
->ts
.type
== BT_CLASS
1758 && !CLASS_DATA (sym
)->attr
.allocatable
1759 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1760 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1761 || sym
->ts
.type
== BT_CLASS
))
1765 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1766 || sym
->as
->type
== AS_ASSUMED_RANK
1767 || sym
->attr
.codimension
))
1768 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1770 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1771 if (sym
->ts
.type
== BT_CLASS
)
1772 tmp
= gfc_class_data_get (tmp
);
1773 tmp
= gfc_conv_array_data (tmp
);
1775 else if (sym
->ts
.type
== BT_CLASS
)
1776 tmp
= gfc_class_data_get (decl
);
1780 if (tmp
!= NULL_TREE
)
1782 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1783 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1784 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1785 logical_type_node
, cond
, tmp
);
1793 /* Converts a missing, dummy argument into a null or zero. */
1796 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1801 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1805 /* Create a temporary and convert it to the correct type. */
1806 tmp
= gfc_get_int_type (kind
);
1807 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1810 /* Test for a NULL value. */
1811 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1812 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1813 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1814 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1818 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1820 build_zero_cst (TREE_TYPE (se
->expr
)));
1821 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1825 if (ts
.type
== BT_CHARACTER
)
1827 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1828 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1829 present
, se
->string_length
, tmp
);
1830 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1831 se
->string_length
= tmp
;
1837 /* Get the character length of an expression, looking through gfc_refs
1841 gfc_get_expr_charlen (gfc_expr
*e
)
1847 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1848 && e
->ts
.type
== BT_CHARACTER
);
1850 length
= NULL
; /* To silence compiler warning. */
1852 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1855 gfc_init_se (&tmpse
, NULL
);
1856 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1857 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1861 /* First candidate: if the variable is of type CHARACTER, the
1862 expression's length could be the length of the character
1864 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1865 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1867 /* Look through the reference chain for component references. */
1868 for (r
= e
->ref
; r
; r
= r
->next
)
1873 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1874 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1882 gfc_init_se (&se
, NULL
);
1883 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
1885 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
1886 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
1887 gfc_charlen_type_node
,
1889 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
1890 gfc_charlen_type_node
, length
,
1891 gfc_index_one_node
);
1900 gcc_assert (length
!= NULL
);
1905 /* Return for an expression the backend decl of the coarray. */
1908 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1914 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1916 /* Not-implemented diagnostic. */
1917 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1918 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1919 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1920 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1921 "%L is not supported", &expr
->where
);
1923 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1924 if (ref
->type
== REF_COMPONENT
)
1926 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1927 && UNLIMITED_POLY (ref
->u
.c
.component
)
1928 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1929 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1930 "component at %L is not supported", &expr
->where
);
1933 /* Make sure the backend_decl is present before accessing it. */
1934 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1935 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1936 : expr
->symtree
->n
.sym
->backend_decl
;
1938 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1940 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1942 caf_decl
= gfc_class_data_get (caf_decl
);
1943 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1946 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1948 if (ref
->type
== REF_COMPONENT
1949 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1951 caf_decl
= gfc_class_data_get (caf_decl
);
1952 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1956 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1960 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1963 /* The following code assumes that the coarray is a component reachable via
1964 only scalar components/variables; the Fortran standard guarantees this. */
1966 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1967 if (ref
->type
== REF_COMPONENT
)
1969 gfc_component
*comp
= ref
->u
.c
.component
;
1971 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1972 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1973 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1974 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1975 comp
->backend_decl
, NULL_TREE
);
1976 if (comp
->ts
.type
== BT_CLASS
)
1978 caf_decl
= gfc_class_data_get (caf_decl
);
1979 if (CLASS_DATA (comp
)->attr
.codimension
)
1985 if (comp
->attr
.codimension
)
1991 gcc_assert (found
&& caf_decl
);
1996 /* Obtain the Coarray token - and optionally also the offset. */
1999 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2000 tree se_expr
, gfc_expr
*expr
)
2004 /* Coarray token. */
2005 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2007 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2008 == GFC_ARRAY_ALLOCATABLE
2009 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2010 *token
= gfc_conv_descriptor_token (caf_decl
);
2012 else if (DECL_LANG_SPECIFIC (caf_decl
)
2013 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2014 *token
= GFC_DECL_TOKEN (caf_decl
);
2017 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2018 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2019 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2025 /* Offset between the coarray base address and the address wanted. */
2026 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2027 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2028 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2029 *offset
= build_int_cst (gfc_array_index_type
, 0);
2030 else if (DECL_LANG_SPECIFIC (caf_decl
)
2031 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2032 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2033 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2034 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2036 *offset
= build_int_cst (gfc_array_index_type
, 0);
2038 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2039 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2041 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2042 tmp
= gfc_conv_descriptor_data_get (tmp
);
2044 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2045 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2048 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2052 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2053 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2055 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2056 && expr
->symtree
->n
.sym
->attr
.codimension
2057 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2059 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2060 gfc_ref
*ref
= base_expr
->ref
;
2063 // Iterate through the refs until the last one.
2067 if (ref
->type
== REF_ARRAY
2068 && ref
->u
.ar
.type
!= AR_FULL
)
2070 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2072 for (i
= 0; i
< ranksum
; ++i
)
2074 ref
->u
.ar
.start
[i
] = NULL
;
2075 ref
->u
.ar
.end
[i
] = NULL
;
2077 ref
->u
.ar
.type
= AR_FULL
;
2079 gfc_init_se (&base_se
, NULL
);
2080 if (gfc_caf_attr (base_expr
).dimension
)
2082 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2083 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2087 gfc_conv_expr (&base_se
, base_expr
);
2091 gfc_free_expr (base_expr
);
2092 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2093 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2095 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2096 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2099 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2103 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2104 fold_convert (gfc_array_index_type
, *offset
),
2105 fold_convert (gfc_array_index_type
, tmp
));
2109 /* Convert the coindex of a coarray into an image index; the result is
2110 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2111 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2114 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2117 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2121 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2122 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2124 gcc_assert (ref
!= NULL
);
2126 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2128 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2132 img_idx
= build_zero_cst (gfc_array_index_type
);
2133 extent
= build_one_cst (gfc_array_index_type
);
2134 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2135 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2137 gfc_init_se (&se
, NULL
);
2138 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2139 gfc_add_block_to_block (block
, &se
.pre
);
2140 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2141 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2142 TREE_TYPE (lbound
), se
.expr
, lbound
);
2143 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2145 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2146 TREE_TYPE (tmp
), img_idx
, tmp
);
2147 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2149 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2150 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2151 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2152 TREE_TYPE (tmp
), extent
, tmp
);
2156 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2158 gfc_init_se (&se
, NULL
);
2159 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2160 gfc_add_block_to_block (block
, &se
.pre
);
2161 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2162 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2163 TREE_TYPE (lbound
), se
.expr
, lbound
);
2164 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2166 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2168 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2170 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2171 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2172 TREE_TYPE (ubound
), ubound
, lbound
);
2173 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2174 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2175 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2176 TREE_TYPE (tmp
), extent
, tmp
);
2179 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2180 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2181 return fold_convert (integer_type_node
, img_idx
);
2185 /* For each character array constructor subexpression without a ts.u.cl->length,
2186 replace it by its first element (if there aren't any elements, the length
2187 should already be set to zero). */
2190 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2192 gfc_actual_arglist
* arg
;
2198 switch (e
->expr_type
)
2202 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2203 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2207 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2211 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2212 flatten_array_ctors_without_strlen (arg
->expr
);
2217 /* We've found what we're looking for. */
2218 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2223 gcc_assert (e
->value
.constructor
);
2225 c
= gfc_constructor_first (e
->value
.constructor
);
2229 flatten_array_ctors_without_strlen (new_expr
);
2230 gfc_replace_expr (e
, new_expr
);
2234 /* Otherwise, fall through to handle constructor elements. */
2236 case EXPR_STRUCTURE
:
2237 for (c
= gfc_constructor_first (e
->value
.constructor
);
2238 c
; c
= gfc_constructor_next (c
))
2239 flatten_array_ctors_without_strlen (c
->expr
);
2249 /* Generate code to initialize a string length variable. Returns the
2250 value. For array constructors, cl->length might be NULL and in this case,
2251 the first element of the constructor is needed. expr is the original
2252 expression so we can access it but can be NULL if this is not needed. */
2255 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2259 gfc_init_se (&se
, NULL
);
2261 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2264 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2265 "flatten" array constructors by taking their first element; all elements
2266 should be the same length or a cl->length should be present. */
2269 gfc_expr
* expr_flat
;
2272 expr_flat
= gfc_copy_expr (expr
);
2273 flatten_array_ctors_without_strlen (expr_flat
);
2274 gfc_resolve_expr (expr_flat
);
2276 gfc_conv_expr (&se
, expr_flat
);
2277 gfc_add_block_to_block (pblock
, &se
.pre
);
2278 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2280 gfc_free_expr (expr_flat
);
2284 /* Convert cl->length. */
2286 gcc_assert (cl
->length
);
2288 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2289 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2290 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2291 gfc_add_block_to_block (pblock
, &se
.pre
);
2293 if (cl
->backend_decl
)
2294 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2296 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2301 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2302 const char *name
, locus
*where
)
2312 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2313 type
= build_pointer_type (type
);
2315 gfc_init_se (&start
, se
);
2316 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2317 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2319 if (integer_onep (start
.expr
))
2320 gfc_conv_string_parameter (se
);
2325 /* Avoid multiple evaluation of substring start. */
2326 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2327 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2329 /* Change the start of the string. */
2330 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2331 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2332 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2335 tmp
= build_fold_indirect_ref_loc (input_location
,
2337 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2338 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
2340 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2341 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2345 /* Length = end + 1 - start. */
2346 gfc_init_se (&end
, se
);
2347 if (ref
->u
.ss
.end
== NULL
)
2348 end
.expr
= se
->string_length
;
2351 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2352 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2356 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2357 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2359 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2361 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2362 logical_type_node
, start
.expr
,
2365 /* Check lower bound. */
2366 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2368 build_one_cst (TREE_TYPE (start
.expr
)));
2369 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2370 logical_type_node
, nonempty
, fault
);
2372 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2373 "is less than one", name
);
2375 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2376 "is less than one");
2377 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2378 fold_convert (long_integer_type_node
,
2382 /* Check upper bound. */
2383 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2384 end
.expr
, se
->string_length
);
2385 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2386 logical_type_node
, nonempty
, fault
);
2388 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2389 "exceeds string length (%%ld)", name
);
2391 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2392 "exceeds string length (%%ld)");
2393 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2394 fold_convert (long_integer_type_node
, end
.expr
),
2395 fold_convert (long_integer_type_node
,
2396 se
->string_length
));
2400 /* Try to calculate the length from the start and end expressions. */
2402 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2404 HOST_WIDE_INT i_len
;
2406 i_len
= gfc_mpz_get_hwi (length
) + 1;
2410 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2411 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2415 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2416 fold_convert (gfc_charlen_type_node
, end
.expr
),
2417 fold_convert (gfc_charlen_type_node
, start
.expr
));
2418 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2419 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2420 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2421 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2424 se
->string_length
= tmp
;
2428 /* Convert a derived type component reference. */
2431 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2439 c
= ref
->u
.c
.component
;
2441 if (c
->backend_decl
== NULL_TREE
2442 && ref
->u
.c
.sym
!= NULL
)
2443 gfc_get_derived_type (ref
->u
.c
.sym
);
2445 field
= c
->backend_decl
;
2446 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2448 context
= DECL_FIELD_CONTEXT (field
);
2450 /* Components can correspond to fields of different containing
2451 types, as components are created without context, whereas
2452 a concrete use of a component has the type of decl as context.
2453 So, if the type doesn't match, we search the corresponding
2454 FIELD_DECL in the parent type. To not waste too much time
2455 we cache this result in norestrict_decl.
2456 On the other hand, if the context is a UNION or a MAP (a
2457 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2459 if (context
!= TREE_TYPE (decl
)
2460 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2461 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2463 tree f2
= c
->norestrict_decl
;
2464 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2465 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2466 if (TREE_CODE (f2
) == FIELD_DECL
2467 && DECL_NAME (f2
) == DECL_NAME (field
))
2470 c
->norestrict_decl
= f2
;
2474 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2475 && strcmp ("_data", c
->name
) == 0)
2477 /* Found a ref to the _data component. Store the associated ref to
2478 the vptr in se->class_vptr. */
2479 se
->class_vptr
= gfc_class_vptr_get (decl
);
2482 se
->class_vptr
= NULL_TREE
;
2484 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2485 decl
, field
, NULL_TREE
);
2489 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2490 strlen () conditional below. */
2491 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2492 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2493 && !c
->attr
.pdt_string
)
2495 tmp
= c
->ts
.u
.cl
->backend_decl
;
2496 /* Components must always be constant length. */
2497 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2498 se
->string_length
= tmp
;
2501 if (gfc_deferred_strlen (c
, &field
))
2503 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2505 decl
, field
, NULL_TREE
);
2506 se
->string_length
= tmp
;
2509 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2510 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2511 && c
->ts
.type
!= BT_CHARACTER
)
2512 || c
->attr
.proc_pointer
)
2513 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2518 /* This function deals with component references to components of the
2519 parent type for derived type extensions. */
2521 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2529 c
= ref
->u
.c
.component
;
2531 /* Return if the component is in the parent type. */
2532 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2533 if (strcmp (c
->name
, cmp
->name
) == 0)
2536 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2537 parent
.type
= REF_COMPONENT
;
2539 parent
.u
.c
.sym
= dt
;
2540 parent
.u
.c
.component
= dt
->components
;
2542 if (dt
->backend_decl
== NULL
)
2543 gfc_get_derived_type (dt
);
2545 /* Build the reference and call self. */
2546 gfc_conv_component_ref (se
, &parent
);
2547 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2548 parent
.u
.c
.component
= c
;
2549 conv_parent_component_references (se
, &parent
);
2554 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2556 tree res
= se
->expr
;
2561 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2562 TREE_TYPE (TREE_TYPE (res
)), res
);
2566 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2567 TREE_TYPE (TREE_TYPE (res
)), res
);
2571 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2576 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2586 /* Dereference VAR where needed if it is a pointer, reference, etc.
2587 according to Fortran semantics. */
2590 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2593 /* Characters are entirely different from other types, they are treated
2595 if (sym
->ts
.type
== BT_CHARACTER
)
2597 /* Dereference character pointer dummy arguments
2599 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2601 || sym
->attr
.function
2602 || sym
->attr
.result
))
2603 var
= build_fold_indirect_ref_loc (input_location
, var
);
2605 else if (!sym
->attr
.value
)
2607 /* Dereference temporaries for class array dummy arguments. */
2608 if (sym
->attr
.dummy
&& is_classarray
2609 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2611 if (!descriptor_only_p
)
2612 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2614 var
= build_fold_indirect_ref_loc (input_location
, var
);
2617 /* Dereference non-character scalar dummy arguments. */
2618 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2619 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2620 && (sym
->ts
.type
!= BT_CLASS
2621 || (!CLASS_DATA (sym
)->attr
.dimension
2622 && !(CLASS_DATA (sym
)->attr
.codimension
2623 && CLASS_DATA (sym
)->attr
.allocatable
))))
2624 var
= build_fold_indirect_ref_loc (input_location
, var
);
2626 /* Dereference scalar hidden result. */
2627 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2628 && (sym
->attr
.function
|| sym
->attr
.result
)
2629 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2630 && !sym
->attr
.always_explicit
)
2631 var
= build_fold_indirect_ref_loc (input_location
, var
);
2633 /* Dereference non-character, non-class pointer variables.
2634 These must be dummies, results, or scalars. */
2636 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2637 || gfc_is_associate_pointer (sym
)
2638 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2640 || sym
->attr
.function
2642 || (!sym
->attr
.dimension
2643 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2644 var
= build_fold_indirect_ref_loc (input_location
, var
);
2645 /* Now treat the class array pointer variables accordingly. */
2646 else if (sym
->ts
.type
== BT_CLASS
2648 && (CLASS_DATA (sym
)->attr
.dimension
2649 || CLASS_DATA (sym
)->attr
.codimension
)
2650 && ((CLASS_DATA (sym
)->as
2651 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2652 || CLASS_DATA (sym
)->attr
.allocatable
2653 || CLASS_DATA (sym
)->attr
.class_pointer
))
2654 var
= build_fold_indirect_ref_loc (input_location
, var
);
2655 /* And the case where a non-dummy, non-result, non-function,
2656 non-allotable and non-pointer classarray is present. This case was
2657 previously covered by the first if, but with introducing the
2658 condition !is_classarray there, that case has to be covered
2660 else if (sym
->ts
.type
== BT_CLASS
2662 && !sym
->attr
.function
2663 && !sym
->attr
.result
2664 && (CLASS_DATA (sym
)->attr
.dimension
2665 || CLASS_DATA (sym
)->attr
.codimension
)
2667 || !CLASS_DATA (sym
)->attr
.allocatable
)
2668 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2669 var
= build_fold_indirect_ref_loc (input_location
, var
);
2675 /* Return the contents of a variable. Also handles reference/pointer
2676 variables (all Fortran pointer references are implicit). */
2679 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2684 tree parent_decl
= NULL_TREE
;
2687 bool alternate_entry
;
2690 bool first_time
= true;
2692 sym
= expr
->symtree
->n
.sym
;
2693 is_classarray
= IS_CLASS_ARRAY (sym
);
2697 gfc_ss_info
*ss_info
= ss
->info
;
2699 /* Check that something hasn't gone horribly wrong. */
2700 gcc_assert (ss
!= gfc_ss_terminator
);
2701 gcc_assert (ss_info
->expr
== expr
);
2703 /* A scalarized term. We already know the descriptor. */
2704 se
->expr
= ss_info
->data
.array
.descriptor
;
2705 se
->string_length
= ss_info
->string_length
;
2706 ref
= ss_info
->data
.array
.ref
;
2708 gcc_assert (ref
->type
== REF_ARRAY
2709 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2711 gfc_conv_tmp_array_ref (se
);
2715 tree se_expr
= NULL_TREE
;
2717 se
->expr
= gfc_get_symbol_decl (sym
);
2719 /* Deal with references to a parent results or entries by storing
2720 the current_function_decl and moving to the parent_decl. */
2721 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2722 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2723 && sym
->result
== sym
;
2724 entry_master
= sym
->attr
.result
2725 && sym
->ns
->proc_name
->attr
.entry_master
2726 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2727 if (current_function_decl
)
2728 parent_decl
= DECL_CONTEXT (current_function_decl
);
2730 if ((se
->expr
== parent_decl
&& return_value
)
2731 || (sym
->ns
&& sym
->ns
->proc_name
2733 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2734 && (alternate_entry
|| entry_master
)))
2739 /* Special case for assigning the return value of a function.
2740 Self recursive functions must have an explicit return value. */
2741 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2742 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2744 /* Similarly for alternate entry points. */
2745 else if (alternate_entry
2746 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2749 gfc_entry_list
*el
= NULL
;
2751 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2754 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2759 else if (entry_master
2760 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2762 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2767 /* Procedure actual arguments. Look out for temporary variables
2768 with the same attributes as function values. */
2769 else if (!sym
->attr
.temporary
2770 && sym
->attr
.flavor
== FL_PROCEDURE
2771 && se
->expr
!= current_function_decl
)
2773 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2775 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2776 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2781 /* Dereference the expression, where needed. */
2782 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
2788 /* For character variables, also get the length. */
2789 if (sym
->ts
.type
== BT_CHARACTER
)
2791 /* If the character length of an entry isn't set, get the length from
2792 the master function instead. */
2793 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2794 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2796 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2797 gcc_assert (se
->string_length
);
2800 gfc_typespec
*ts
= &sym
->ts
;
2806 /* Return the descriptor if that's what we want and this is an array
2807 section reference. */
2808 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2810 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2811 /* Return the descriptor for array pointers and allocations. */
2812 if (se
->want_pointer
2813 && ref
->next
== NULL
&& (se
->descriptor_only
))
2816 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2817 /* Return a pointer to an element. */
2821 ts
= &ref
->u
.c
.component
->ts
;
2822 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2823 && se
->descriptor_only
2824 && !CLASS_DATA (sym
)->attr
.allocatable
2825 && !CLASS_DATA (sym
)->attr
.class_pointer
2826 && CLASS_DATA (sym
)->as
2827 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2828 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2829 /* Skip the first ref of a _data component, because for class
2830 arrays that one is already done by introducing a temporary
2831 array descriptor. */
2834 if (ref
->u
.c
.sym
->attr
.extension
)
2835 conv_parent_component_references (se
, ref
);
2837 gfc_conv_component_ref (se
, ref
);
2838 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2839 && se
->want_pointer
&& se
->descriptor_only
)
2845 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2846 expr
->symtree
->name
, &expr
->where
);
2850 conv_inquiry (se
, ref
, expr
, ts
);
2860 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2862 if (se
->want_pointer
)
2864 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2865 gfc_conv_string_parameter (se
);
2867 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2872 /* Unary ops are easy... Or they would be if ! was a valid op. */
2875 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2880 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2881 /* Initialize the operand. */
2882 gfc_init_se (&operand
, se
);
2883 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2884 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2886 type
= gfc_typenode_for_spec (&expr
->ts
);
2888 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2889 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2890 All other unary operators have an equivalent GIMPLE unary operator. */
2891 if (code
== TRUTH_NOT_EXPR
)
2892 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2893 build_int_cst (type
, 0));
2895 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2899 /* Expand power operator to optimal multiplications when a value is raised
2900 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2901 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2902 Programming", 3rd Edition, 1998. */
2904 /* This code is mostly duplicated from expand_powi in the backend.
2905 We establish the "optimal power tree" lookup table with the defined size.
2906 The items in the table are the exponents used to calculate the index
2907 exponents. Any integer n less than the value can get an "addition chain",
2908 with the first node being one. */
2909 #define POWI_TABLE_SIZE 256
2911 /* The table is from builtins.c. */
2912 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2914 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2915 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2916 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2917 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2918 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2919 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2920 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2921 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2922 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2923 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2924 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2925 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2926 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2927 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2928 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2929 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2930 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2931 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2932 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2933 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2934 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2935 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2936 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2937 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2938 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2939 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2940 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2941 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2942 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2943 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2944 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2945 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2948 /* If n is larger than lookup table's max index, we use the "window
2950 #define POWI_WINDOW_SIZE 3
2952 /* Recursive function to expand the power operator. The temporary
2953 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2955 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2962 if (n
< POWI_TABLE_SIZE
)
2967 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2968 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2972 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2973 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2974 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2978 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2982 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2983 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2985 if (n
< POWI_TABLE_SIZE
)
2992 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2993 return 1. Else return 0 and a call to runtime library functions
2994 will have to be built. */
2996 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3001 tree vartmp
[POWI_TABLE_SIZE
];
3003 unsigned HOST_WIDE_INT n
;
3005 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3007 /* If exponent is too large, we won't expand it anyway, so don't bother
3008 with large integer values. */
3009 if (!wi::fits_shwi_p (wrhs
))
3012 m
= wrhs
.to_shwi ();
3013 /* Use the wide_int's routine to reliably get the absolute value on all
3014 platforms. Then convert it to a HOST_WIDE_INT like above. */
3015 n
= wi::abs (wrhs
).to_shwi ();
3017 type
= TREE_TYPE (lhs
);
3018 sgn
= tree_int_cst_sgn (rhs
);
3020 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3021 || optimize_size
) && (m
> 2 || m
< -1))
3027 se
->expr
= gfc_build_const (type
, integer_one_node
);
3031 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3032 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3034 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3035 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3036 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3037 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3040 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3043 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3044 logical_type_node
, tmp
, cond
);
3045 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3046 tmp
, build_int_cst (type
, 1),
3047 build_int_cst (type
, 0));
3051 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3052 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3053 build_int_cst (type
, -1),
3054 build_int_cst (type
, 0));
3055 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3056 cond
, build_int_cst (type
, 1), tmp
);
3060 memset (vartmp
, 0, sizeof (vartmp
));
3064 tmp
= gfc_build_const (type
, integer_one_node
);
3065 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3069 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3075 /* Power op (**). Constant integer exponent has special handling. */
3078 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3080 tree gfc_int4_type_node
;
3083 int res_ikind_1
, res_ikind_2
;
3088 gfc_init_se (&lse
, se
);
3089 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3090 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3091 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3093 gfc_init_se (&rse
, se
);
3094 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3095 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3097 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3098 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3099 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3102 if (INTEGER_CST_P (lse
.expr
)
3103 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3105 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3107 int kind
, ikind
, bit_size
;
3109 v
= wlhs
.to_shwi ();
3112 kind
= expr
->value
.op
.op1
->ts
.kind
;
3113 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3114 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3118 /* 1**something is always 1. */
3119 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3124 /* (-1)**n is 1 - ((n & 1) << 1) */
3128 type
= TREE_TYPE (lse
.expr
);
3129 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3130 rse
.expr
, build_int_cst (type
, 1));
3131 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3132 tmp
, build_int_cst (type
, 1));
3133 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3134 build_int_cst (type
, 1), tmp
);
3138 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3140 /* Here v is +/- 2**e. The further simplification uses
3141 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3142 1<<(4*n), etc., but we have to make sure to return zero
3143 if the number of bits is too large. */
3153 type
= TREE_TYPE (lse
.expr
);
3158 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3159 TREE_TYPE (rse
.expr
),
3160 rse
.expr
, rse
.expr
);
3163 /* use popcount for fast log2(w) */
3164 int e
= wi::popcount (w
-1);
3165 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3166 TREE_TYPE (rse
.expr
),
3167 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3171 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3172 build_int_cst (type
, 1), shift
);
3173 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3174 rse
.expr
, build_int_cst (type
, 0));
3175 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3176 build_int_cst (type
, 0));
3177 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3178 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3179 rse
.expr
, num_bits
);
3180 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3181 build_int_cst (type
, 0), cond
);
3188 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3190 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3191 rse
.expr
, build_int_cst (type
, 1));
3192 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3193 tmp2
, build_int_cst (type
, 1));
3194 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3195 build_int_cst (type
, 1), tmp2
);
3196 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3203 gfc_int4_type_node
= gfc_get_int_type (4);
3205 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3206 library routine. But in the end, we have to convert the result back
3207 if this case applies -- with res_ikind_K, we keep track whether operand K
3208 falls into this case. */
3212 kind
= expr
->value
.op
.op1
->ts
.kind
;
3213 switch (expr
->value
.op
.op2
->ts
.type
)
3216 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3221 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3222 res_ikind_2
= ikind
;
3244 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3246 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3273 switch (expr
->value
.op
.op1
->ts
.type
)
3276 if (kind
== 3) /* Case 16 was not handled properly above. */
3278 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3282 /* Use builtins for real ** int4. */
3288 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3292 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3296 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3300 /* Use the __builtin_powil() only if real(kind=16) is
3301 actually the C long double type. */
3302 if (!gfc_real16_is_float128
)
3303 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3311 /* If we don't have a good builtin for this, go for the
3312 library function. */
3314 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3318 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3327 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3331 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3339 se
->expr
= build_call_expr_loc (input_location
,
3340 fndecl
, 2, lse
.expr
, rse
.expr
);
3342 /* Convert the result back if it is of wrong integer kind. */
3343 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3345 /* We want the maximum of both operand kinds as result. */
3346 if (res_ikind_1
< res_ikind_2
)
3347 res_ikind_1
= res_ikind_2
;
3348 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3353 /* Generate code to allocate a string temporary. */
3356 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3361 if (gfc_can_put_var_on_stack (len
))
3363 /* Create a temporary variable to hold the result. */
3364 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3365 TREE_TYPE (len
), len
,
3366 build_int_cst (TREE_TYPE (len
), 1));
3367 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3369 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3370 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3372 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3374 var
= gfc_create_var (tmp
, "str");
3375 var
= gfc_build_addr_expr (type
, var
);
3379 /* Allocate a temporary to hold the result. */
3380 var
= gfc_create_var (type
, "pstr");
3381 gcc_assert (POINTER_TYPE_P (type
));
3382 tmp
= TREE_TYPE (type
);
3383 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3384 tmp
= TREE_TYPE (tmp
);
3385 tmp
= TYPE_SIZE_UNIT (tmp
);
3386 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3387 fold_convert (size_type_node
, len
),
3388 fold_convert (size_type_node
, tmp
));
3389 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3390 gfc_add_modify (&se
->pre
, var
, tmp
);
3392 /* Free the temporary afterwards. */
3393 tmp
= gfc_call_free (var
);
3394 gfc_add_expr_to_block (&se
->post
, tmp
);
3401 /* Handle a string concatenation operation. A temporary will be allocated to
3405 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3408 tree len
, type
, var
, tmp
, fndecl
;
3410 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3411 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3412 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3414 gfc_init_se (&lse
, se
);
3415 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3416 gfc_conv_string_parameter (&lse
);
3417 gfc_init_se (&rse
, se
);
3418 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3419 gfc_conv_string_parameter (&rse
);
3421 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3422 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3424 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3425 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3426 if (len
== NULL_TREE
)
3428 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3429 gfc_charlen_type_node
,
3430 fold_convert (gfc_charlen_type_node
,
3432 fold_convert (gfc_charlen_type_node
,
3433 rse
.string_length
));
3436 type
= build_pointer_type (type
);
3438 var
= gfc_conv_string_tmp (se
, type
, len
);
3440 /* Do the actual concatenation. */
3441 if (expr
->ts
.kind
== 1)
3442 fndecl
= gfor_fndecl_concat_string
;
3443 else if (expr
->ts
.kind
== 4)
3444 fndecl
= gfor_fndecl_concat_string_char4
;
3448 tmp
= build_call_expr_loc (input_location
,
3449 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3450 rse
.string_length
, rse
.expr
);
3451 gfc_add_expr_to_block (&se
->pre
, tmp
);
3453 /* Add the cleanup for the operands. */
3454 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3455 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3458 se
->string_length
= len
;
3461 /* Translates an op expression. Common (binary) cases are handled by this
3462 function, others are passed on. Recursion is used in either case.
3463 We use the fact that (op1.ts == op2.ts) (except for the power
3465 Operators need no special handling for scalarized expressions as long as
3466 they call gfc_conv_simple_val to get their operands.
3467 Character strings get special handling. */
3470 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3472 enum tree_code code
;
3481 switch (expr
->value
.op
.op
)
3483 case INTRINSIC_PARENTHESES
:
3484 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3485 && flag_protect_parens
)
3487 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3488 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3493 case INTRINSIC_UPLUS
:
3494 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3497 case INTRINSIC_UMINUS
:
3498 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3502 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3505 case INTRINSIC_PLUS
:
3509 case INTRINSIC_MINUS
:
3513 case INTRINSIC_TIMES
:
3517 case INTRINSIC_DIVIDE
:
3518 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3519 an integer, we must round towards zero, so we use a
3521 if (expr
->ts
.type
== BT_INTEGER
)
3522 code
= TRUNC_DIV_EXPR
;
3527 case INTRINSIC_POWER
:
3528 gfc_conv_power_op (se
, expr
);
3531 case INTRINSIC_CONCAT
:
3532 gfc_conv_concat_op (se
, expr
);
3536 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3541 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3545 /* EQV and NEQV only work on logicals, but since we represent them
3546 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3548 case INTRINSIC_EQ_OS
:
3556 case INTRINSIC_NE_OS
:
3557 case INTRINSIC_NEQV
:
3564 case INTRINSIC_GT_OS
:
3571 case INTRINSIC_GE_OS
:
3578 case INTRINSIC_LT_OS
:
3585 case INTRINSIC_LE_OS
:
3591 case INTRINSIC_USER
:
3592 case INTRINSIC_ASSIGN
:
3593 /* These should be converted into function calls by the frontend. */
3597 fatal_error (input_location
, "Unknown intrinsic op");
3601 /* The only exception to this is **, which is handled separately anyway. */
3602 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3604 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3608 gfc_init_se (&lse
, se
);
3609 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3610 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3613 gfc_init_se (&rse
, se
);
3614 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3615 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3619 gfc_conv_string_parameter (&lse
);
3620 gfc_conv_string_parameter (&rse
);
3622 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3623 rse
.string_length
, rse
.expr
,
3624 expr
->value
.op
.op1
->ts
.kind
,
3626 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3627 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3630 type
= gfc_typenode_for_spec (&expr
->ts
);
3634 /* The result of logical ops is always logical_type_node. */
3635 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3636 lse
.expr
, rse
.expr
);
3637 se
->expr
= convert (type
, tmp
);
3640 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3642 /* Add the post blocks. */
3643 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3644 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3647 /* If a string's length is one, we convert it to a single character. */
3650 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3654 || !tree_fits_uhwi_p (len
)
3655 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3658 if (TREE_INT_CST_LOW (len
) == 1)
3660 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3661 return build_fold_indirect_ref_loc (input_location
, str
);
3665 && TREE_CODE (str
) == ADDR_EXPR
3666 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3667 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3668 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3669 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3670 && TREE_INT_CST_LOW (len
) > 1
3671 && TREE_INT_CST_LOW (len
)
3672 == (unsigned HOST_WIDE_INT
)
3673 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3675 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3676 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3677 if (TREE_CODE (ret
) == INTEGER_CST
)
3679 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3680 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3681 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3683 for (i
= 1; i
< length
; i
++)
3696 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3699 if (sym
->backend_decl
)
3701 /* This becomes the nominal_type in
3702 function.c:assign_parm_find_data_types. */
3703 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3704 /* This becomes the passed_type in
3705 function.c:assign_parm_find_data_types. C promotes char to
3706 integer for argument passing. */
3707 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3709 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3714 /* If we have a constant character expression, make it into an
3716 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3721 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3722 (int)(*expr
)->value
.character
.string
[0]);
3723 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3725 /* The expr needs to be compatible with a C int. If the
3726 conversion fails, then the 2 causes an ICE. */
3727 ts
.type
= BT_INTEGER
;
3728 ts
.kind
= gfc_c_int_kind
;
3729 gfc_convert_type (*expr
, &ts
, 2);
3732 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3734 if ((*expr
)->ref
== NULL
)
3736 se
->expr
= gfc_string_to_single_character
3737 (build_int_cst (integer_type_node
, 1),
3738 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3740 ((*expr
)->symtree
->n
.sym
)),
3745 gfc_conv_variable (se
, *expr
);
3746 se
->expr
= gfc_string_to_single_character
3747 (build_int_cst (integer_type_node
, 1),
3748 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3756 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3757 if STR is a string literal, otherwise return -1. */
3760 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3763 && TREE_CODE (str
) == ADDR_EXPR
3764 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3765 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3766 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3767 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3768 && tree_fits_uhwi_p (len
)
3769 && tree_to_uhwi (len
) >= 1
3770 && tree_to_uhwi (len
)
3771 == (unsigned HOST_WIDE_INT
)
3772 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3774 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3775 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3776 if (TREE_CODE (folded
) == INTEGER_CST
)
3778 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3779 int length
= TREE_STRING_LENGTH (string_cst
);
3780 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3782 for (; length
> 0; length
--)
3783 if (ptr
[length
- 1] != ' ')
3792 /* Helper to build a call to memcmp. */
3795 build_memcmp_call (tree s1
, tree s2
, tree n
)
3799 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3800 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3802 s1
= fold_convert (pvoid_type_node
, s1
);
3804 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3805 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3807 s2
= fold_convert (pvoid_type_node
, s2
);
3809 n
= fold_convert (size_type_node
, n
);
3811 tmp
= build_call_expr_loc (input_location
,
3812 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3815 return fold_convert (integer_type_node
, tmp
);
3818 /* Compare two strings. If they are all single characters, the result is the
3819 subtraction of them. Otherwise, we build a library call. */
3822 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3823 enum tree_code code
)
3829 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3830 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3832 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3833 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3835 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3837 /* Deal with single character specially. */
3838 sc1
= fold_convert (integer_type_node
, sc1
);
3839 sc2
= fold_convert (integer_type_node
, sc2
);
3840 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3844 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3846 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3848 /* If one string is a string literal with LEN_TRIM longer
3849 than the length of the second string, the strings
3851 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3852 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3853 return integer_one_node
;
3854 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3855 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3856 return integer_one_node
;
3859 /* We can compare via memcpy if the strings are known to be equal
3860 in length and they are
3862 - kind=4 and the comparison is for (in)equality. */
3864 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3865 && tree_int_cst_equal (len1
, len2
)
3866 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3871 chartype
= gfc_get_char_type (kind
);
3872 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3873 fold_convert (TREE_TYPE(len1
),
3874 TYPE_SIZE_UNIT(chartype
)),
3876 return build_memcmp_call (str1
, str2
, tmp
);
3879 /* Build a call for the comparison. */
3881 fndecl
= gfor_fndecl_compare_string
;
3883 fndecl
= gfor_fndecl_compare_string_char4
;
3887 return build_call_expr_loc (input_location
, fndecl
, 4,
3888 len1
, str1
, len2
, str2
);
3892 /* Return the backend_decl for a procedure pointer component. */
3895 get_proc_ptr_comp (gfc_expr
*e
)
3901 gfc_init_se (&comp_se
, NULL
);
3902 e2
= gfc_copy_expr (e
);
3903 /* We have to restore the expr type later so that gfc_free_expr frees
3904 the exact same thing that was allocated.
3905 TODO: This is ugly. */
3906 old_type
= e2
->expr_type
;
3907 e2
->expr_type
= EXPR_VARIABLE
;
3908 gfc_conv_expr (&comp_se
, e2
);
3909 e2
->expr_type
= old_type
;
3911 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3915 /* Convert a typebound function reference from a class object. */
3917 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3922 if (!VAR_P (base_object
))
3924 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3925 gfc_add_modify (&se
->pre
, var
, base_object
);
3927 se
->expr
= gfc_class_vptr_get (base_object
);
3928 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3930 while (ref
&& ref
->next
)
3932 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3933 if (ref
->u
.c
.sym
->attr
.extension
)
3934 conv_parent_component_references (se
, ref
);
3935 gfc_conv_component_ref (se
, ref
);
3936 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3941 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
3942 gfc_actual_arglist
*actual_args
)
3946 if (gfc_is_proc_ptr_comp (expr
))
3947 tmp
= get_proc_ptr_comp (expr
);
3948 else if (sym
->attr
.dummy
)
3950 tmp
= gfc_get_symbol_decl (sym
);
3951 if (sym
->attr
.proc_pointer
)
3952 tmp
= build_fold_indirect_ref_loc (input_location
,
3954 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3955 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3959 if (!sym
->backend_decl
)
3960 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
3962 TREE_USED (sym
->backend_decl
) = 1;
3964 tmp
= sym
->backend_decl
;
3966 if (sym
->attr
.cray_pointee
)
3968 /* TODO - make the cray pointee a pointer to a procedure,
3969 assign the pointer to it and use it for the call. This
3971 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3972 gfc_get_symbol_decl (sym
->cp_pointer
));
3973 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3976 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3978 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3979 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3986 /* Initialize MAPPING. */
3989 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3991 mapping
->syms
= NULL
;
3992 mapping
->charlens
= NULL
;
3996 /* Free all memory held by MAPPING (but not MAPPING itself). */
3999 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4001 gfc_interface_sym_mapping
*sym
;
4002 gfc_interface_sym_mapping
*nextsym
;
4004 gfc_charlen
*nextcl
;
4006 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4008 nextsym
= sym
->next
;
4009 sym
->new_sym
->n
.sym
->formal
= NULL
;
4010 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4011 gfc_free_expr (sym
->expr
);
4012 free (sym
->new_sym
);
4015 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4018 gfc_free_expr (cl
->length
);
4024 /* Return a copy of gfc_charlen CL. Add the returned structure to
4025 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4027 static gfc_charlen
*
4028 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4031 gfc_charlen
*new_charlen
;
4033 new_charlen
= gfc_get_charlen ();
4034 new_charlen
->next
= mapping
->charlens
;
4035 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4037 mapping
->charlens
= new_charlen
;
4042 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4043 array variable that can be used as the actual argument for dummy
4044 argument SYM. Add any initialization code to BLOCK. PACKED is as
4045 for gfc_get_nodesc_array_type and DATA points to the first element
4046 in the passed array. */
4049 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4050 gfc_packed packed
, tree data
)
4055 type
= gfc_typenode_for_spec (&sym
->ts
);
4056 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4057 !sym
->attr
.target
&& !sym
->attr
.pointer
4058 && !sym
->attr
.proc_pointer
);
4060 var
= gfc_create_var (type
, "ifm");
4061 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4067 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4068 and offset of descriptorless array type TYPE given that it has the same
4069 size as DESC. Add any set-up code to BLOCK. */
4072 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4079 offset
= gfc_index_zero_node
;
4080 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4082 dim
= gfc_rank_cst
[n
];
4083 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4084 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4086 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4087 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4088 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4089 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4091 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4093 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4094 gfc_array_index_type
,
4095 gfc_conv_descriptor_ubound_get (desc
, dim
),
4096 gfc_conv_descriptor_lbound_get (desc
, dim
));
4097 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4098 gfc_array_index_type
,
4099 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4100 tmp
= gfc_evaluate_now (tmp
, block
);
4101 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4103 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4104 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4105 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4106 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4107 gfc_array_index_type
, offset
, tmp
);
4109 offset
= gfc_evaluate_now (offset
, block
);
4110 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4114 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4115 in SE. The caller may still use se->expr and se->string_length after
4116 calling this function. */
4119 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4120 gfc_symbol
* sym
, gfc_se
* se
,
4123 gfc_interface_sym_mapping
*sm
;
4127 gfc_symbol
*new_sym
;
4129 gfc_symtree
*new_symtree
;
4131 /* Create a new symbol to represent the actual argument. */
4132 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4133 new_sym
->ts
= sym
->ts
;
4134 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4135 new_sym
->attr
.referenced
= 1;
4136 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4137 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4138 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4139 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4140 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4141 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4142 new_sym
->attr
.function
= sym
->attr
.function
;
4144 /* Ensure that the interface is available and that
4145 descriptors are passed for array actual arguments. */
4146 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4148 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4149 new_sym
->attr
.always_explicit
4150 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4153 /* Create a fake symtree for it. */
4155 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4156 new_symtree
->n
.sym
= new_sym
;
4157 gcc_assert (new_symtree
== root
);
4159 /* Create a dummy->actual mapping. */
4160 sm
= XCNEW (gfc_interface_sym_mapping
);
4161 sm
->next
= mapping
->syms
;
4163 sm
->new_sym
= new_symtree
;
4164 sm
->expr
= gfc_copy_expr (expr
);
4167 /* Stabilize the argument's value. */
4168 if (!sym
->attr
.function
&& se
)
4169 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4171 if (sym
->ts
.type
== BT_CHARACTER
)
4173 /* Create a copy of the dummy argument's length. */
4174 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4175 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4177 /* If the length is specified as "*", record the length that
4178 the caller is passing. We should use the callee's length
4179 in all other cases. */
4180 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4182 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4183 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4190 /* Use the passed value as-is if the argument is a function. */
4191 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4194 /* If the argument is a pass-by-value scalar, use the value as is. */
4195 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4198 /* If the argument is either a string or a pointer to a string,
4199 convert it to a boundless character type. */
4200 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4202 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4203 tmp
= build_pointer_type (tmp
);
4204 if (sym
->attr
.pointer
)
4205 value
= build_fold_indirect_ref_loc (input_location
,
4209 value
= fold_convert (tmp
, value
);
4212 /* If the argument is a scalar, a pointer to an array or an allocatable,
4214 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4215 value
= build_fold_indirect_ref_loc (input_location
,
4218 /* For character(*), use the actual argument's descriptor. */
4219 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4220 value
= build_fold_indirect_ref_loc (input_location
,
4223 /* If the argument is an array descriptor, use it to determine
4224 information about the actual argument's shape. */
4225 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4226 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4228 /* Get the actual argument's descriptor. */
4229 desc
= build_fold_indirect_ref_loc (input_location
,
4232 /* Create the replacement variable. */
4233 tmp
= gfc_conv_descriptor_data_get (desc
);
4234 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4237 /* Use DESC to work out the upper bounds, strides and offset. */
4238 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4241 /* Otherwise we have a packed array. */
4242 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4243 PACKED_FULL
, se
->expr
);
4245 new_sym
->backend_decl
= value
;
4249 /* Called once all dummy argument mappings have been added to MAPPING,
4250 but before the mapping is used to evaluate expressions. Pre-evaluate
4251 the length of each argument, adding any initialization code to PRE and
4252 any finalization code to POST. */
4255 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4256 stmtblock_t
* pre
, stmtblock_t
* post
)
4258 gfc_interface_sym_mapping
*sym
;
4262 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4263 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4264 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4266 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4267 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4268 gfc_init_se (&se
, NULL
);
4269 gfc_conv_expr (&se
, expr
);
4270 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4271 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4272 gfc_add_block_to_block (pre
, &se
.pre
);
4273 gfc_add_block_to_block (post
, &se
.post
);
4275 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4280 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4284 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4285 gfc_constructor_base base
)
4288 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4290 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4293 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4294 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4295 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4301 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4305 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4310 for (; ref
; ref
= ref
->next
)
4314 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4316 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4317 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4318 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4327 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4328 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4334 /* Convert intrinsic function calls into result expressions. */
4337 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4345 arg1
= expr
->value
.function
.actual
->expr
;
4346 if (expr
->value
.function
.actual
->next
)
4347 arg2
= expr
->value
.function
.actual
->next
->expr
;
4351 sym
= arg1
->symtree
->n
.sym
;
4353 if (sym
->attr
.dummy
)
4358 switch (expr
->value
.function
.isym
->id
)
4361 /* TODO figure out why this condition is necessary. */
4362 if (sym
->attr
.function
4363 && (arg1
->ts
.u
.cl
->length
== NULL
4364 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4365 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4368 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4371 case GFC_ISYM_LEN_TRIM
:
4372 new_expr
= gfc_copy_expr (arg1
);
4373 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4378 gfc_replace_expr (arg1
, new_expr
);
4382 if (!sym
->as
|| sym
->as
->rank
== 0)
4385 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4387 dup
= mpz_get_si (arg2
->value
.integer
);
4392 dup
= sym
->as
->rank
;
4396 for (; d
< dup
; d
++)
4400 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4402 gfc_free_expr (new_expr
);
4406 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4407 gfc_get_int_expr (gfc_default_integer_kind
,
4409 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4411 new_expr
= gfc_multiply (new_expr
, tmp
);
4417 case GFC_ISYM_LBOUND
:
4418 case GFC_ISYM_UBOUND
:
4419 /* TODO These implementations of lbound and ubound do not limit if
4420 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4422 if (!sym
->as
|| sym
->as
->rank
== 0)
4425 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4426 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4430 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4432 if (sym
->as
->lower
[d
])
4433 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4437 if (sym
->as
->upper
[d
])
4438 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4446 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4450 gfc_replace_expr (expr
, new_expr
);
4456 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4457 gfc_interface_mapping
* mapping
)
4459 gfc_formal_arglist
*f
;
4460 gfc_actual_arglist
*actual
;
4462 actual
= expr
->value
.function
.actual
;
4463 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4465 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4470 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4473 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4478 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4480 for (d
= 0; d
< as
->rank
; d
++)
4482 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4483 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4486 expr
->value
.function
.esym
->as
= as
;
4489 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4491 expr
->value
.function
.esym
->ts
.u
.cl
->length
4492 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4494 gfc_apply_interface_mapping_to_expr (mapping
,
4495 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4500 /* EXPR is a copy of an expression that appeared in the interface
4501 associated with MAPPING. Walk it recursively looking for references to
4502 dummy arguments that MAPPING maps to actual arguments. Replace each such
4503 reference with a reference to the associated actual argument. */
4506 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4509 gfc_interface_sym_mapping
*sym
;
4510 gfc_actual_arglist
*actual
;
4515 /* Copying an expression does not copy its length, so do that here. */
4516 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4518 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4519 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4522 /* Apply the mapping to any references. */
4523 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4525 /* ...and to the expression's symbol, if it has one. */
4526 /* TODO Find out why the condition on expr->symtree had to be moved into
4527 the loop rather than being outside it, as originally. */
4528 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4529 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4531 if (sym
->new_sym
->n
.sym
->backend_decl
)
4532 expr
->symtree
= sym
->new_sym
;
4534 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4537 /* ...and to subexpressions in expr->value. */
4538 switch (expr
->expr_type
)
4543 case EXPR_SUBSTRING
:
4547 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4548 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4552 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4553 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4555 if (expr
->value
.function
.esym
== NULL
4556 && expr
->value
.function
.isym
!= NULL
4557 && expr
->value
.function
.actual
4558 && expr
->value
.function
.actual
->expr
4559 && expr
->value
.function
.actual
->expr
->symtree
4560 && gfc_map_intrinsic_function (expr
, mapping
))
4563 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4564 if (sym
->old
== expr
->value
.function
.esym
)
4566 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4567 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4568 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4573 case EXPR_STRUCTURE
:
4574 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4588 /* Evaluate interface expression EXPR using MAPPING. Store the result
4592 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4593 gfc_se
* se
, gfc_expr
* expr
)
4595 expr
= gfc_copy_expr (expr
);
4596 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4597 gfc_conv_expr (se
, expr
);
4598 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4599 gfc_free_expr (expr
);
4603 /* Returns a reference to a temporary array into which a component of
4604 an actual argument derived type array is copied and then returned
4605 after the function call. */
4607 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4608 sym_intent intent
, bool formal_ptr
,
4609 const gfc_symbol
*fsym
, const char *proc_name
,
4610 gfc_symbol
*sym
, bool check_contiguous
)
4618 gfc_array_info
*info
;
4631 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4633 if (pass_optional
|| check_contiguous
)
4635 gfc_init_se (&work_se
, NULL
);
4641 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4643 /* We will create a temporary array, so let us warn. */
4646 if (fsym
&& proc_name
)
4647 msg
= xasprintf ("An array temporary was created for argument "
4648 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4650 msg
= xasprintf ("An array temporary was created");
4652 tmp
= build_int_cst (logical_type_node
, 1);
4653 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4658 gfc_init_se (&lse
, NULL
);
4659 gfc_init_se (&rse
, NULL
);
4661 /* Walk the argument expression. */
4662 rss
= gfc_walk_expr (expr
);
4664 gcc_assert (rss
!= gfc_ss_terminator
);
4666 /* Initialize the scalarizer. */
4667 gfc_init_loopinfo (&loop
);
4668 gfc_add_ss_to_loop (&loop
, rss
);
4670 /* Calculate the bounds of the scalarization. */
4671 gfc_conv_ss_startstride (&loop
);
4673 /* Build an ss for the temporary. */
4674 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4675 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4677 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4678 if (GFC_ARRAY_TYPE_P (base_type
)
4679 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4680 base_type
= gfc_get_element_type (base_type
);
4682 if (expr
->ts
.type
== BT_CLASS
)
4683 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4685 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4686 ? expr
->ts
.u
.cl
->backend_decl
4690 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4692 /* Associate the SS with the loop. */
4693 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4695 /* Setup the scalarizing loops. */
4696 gfc_conv_loop_setup (&loop
, &expr
->where
);
4698 /* Pass the temporary descriptor back to the caller. */
4699 info
= &loop
.temp_ss
->info
->data
.array
;
4700 parmse
->expr
= info
->descriptor
;
4702 /* Setup the gfc_se structures. */
4703 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4704 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4707 lse
.ss
= loop
.temp_ss
;
4708 gfc_mark_ss_chain_used (rss
, 1);
4709 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4711 /* Start the scalarized loop body. */
4712 gfc_start_scalarized_body (&loop
, &body
);
4714 /* Translate the expression. */
4715 gfc_conv_expr (&rse
, expr
);
4717 /* Reset the offset for the function call since the loop
4718 is zero based on the data pointer. Note that the temp
4719 comes first in the loop chain since it is added second. */
4720 if (gfc_is_class_array_function (expr
))
4722 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4723 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4724 gfc_index_zero_node
);
4727 gfc_conv_tmp_array_ref (&lse
);
4729 if (intent
!= INTENT_OUT
)
4731 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4732 gfc_add_expr_to_block (&body
, tmp
);
4733 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4734 gfc_trans_scalarizing_loops (&loop
, &body
);
4738 /* Make sure that the temporary declaration survives by merging
4739 all the loop declarations into the current context. */
4740 for (n
= 0; n
< loop
.dimen
; n
++)
4742 gfc_merge_block_scope (&body
);
4743 body
= loop
.code
[loop
.order
[n
]];
4745 gfc_merge_block_scope (&body
);
4748 /* Add the post block after the second loop, so that any
4749 freeing of allocated memory is done at the right time. */
4750 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4752 /**********Copy the temporary back again.*********/
4754 gfc_init_se (&lse
, NULL
);
4755 gfc_init_se (&rse
, NULL
);
4757 /* Walk the argument expression. */
4758 lss
= gfc_walk_expr (expr
);
4759 rse
.ss
= loop
.temp_ss
;
4762 /* Initialize the scalarizer. */
4763 gfc_init_loopinfo (&loop2
);
4764 gfc_add_ss_to_loop (&loop2
, lss
);
4766 dimen
= rse
.ss
->dimen
;
4768 /* Skip the write-out loop for this case. */
4769 if (gfc_is_class_array_function (expr
))
4770 goto class_array_fcn
;
4772 /* Calculate the bounds of the scalarization. */
4773 gfc_conv_ss_startstride (&loop2
);
4775 /* Setup the scalarizing loops. */
4776 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4778 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4779 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4781 gfc_mark_ss_chain_used (lss
, 1);
4782 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4784 /* Declare the variable to hold the temporary offset and start the
4785 scalarized loop body. */
4786 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4787 gfc_start_scalarized_body (&loop2
, &body
);
4789 /* Build the offsets for the temporary from the loop variables. The
4790 temporary array has lbounds of zero and strides of one in all
4791 dimensions, so this is very simple. The offset is only computed
4792 outside the innermost loop, so the overall transfer could be
4793 optimized further. */
4794 info
= &rse
.ss
->info
->data
.array
;
4796 tmp_index
= gfc_index_zero_node
;
4797 for (n
= dimen
- 1; n
> 0; n
--)
4800 tmp
= rse
.loop
->loopvar
[n
];
4801 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4802 tmp
, rse
.loop
->from
[n
]);
4803 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4806 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4807 gfc_array_index_type
,
4808 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4809 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4810 gfc_array_index_type
,
4811 tmp_str
, gfc_index_one_node
);
4813 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4814 gfc_array_index_type
, tmp
, tmp_str
);
4817 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4818 gfc_array_index_type
,
4819 tmp_index
, rse
.loop
->from
[0]);
4820 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4822 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4823 gfc_array_index_type
,
4824 rse
.loop
->loopvar
[0], offset
);
4826 /* Now use the offset for the reference. */
4827 tmp
= build_fold_indirect_ref_loc (input_location
,
4829 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4831 if (expr
->ts
.type
== BT_CHARACTER
)
4832 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4834 gfc_conv_expr (&lse
, expr
);
4836 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4838 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4839 gfc_add_expr_to_block (&body
, tmp
);
4841 /* Generate the copying loops. */
4842 gfc_trans_scalarizing_loops (&loop2
, &body
);
4844 /* Wrap the whole thing up by adding the second loop to the post-block
4845 and following it by the post-block of the first loop. In this way,
4846 if the temporary needs freeing, it is done after use! */
4847 if (intent
!= INTENT_IN
)
4849 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4850 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4855 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4857 gfc_cleanup_loop (&loop
);
4858 gfc_cleanup_loop (&loop2
);
4860 /* Pass the string length to the argument expression. */
4861 if (expr
->ts
.type
== BT_CHARACTER
)
4862 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4864 /* Determine the offset for pointer formal arguments and set the
4868 size
= gfc_index_one_node
;
4869 offset
= gfc_index_zero_node
;
4870 for (n
= 0; n
< dimen
; n
++)
4872 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4874 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4875 gfc_array_index_type
, tmp
,
4876 gfc_index_one_node
);
4877 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4881 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4884 gfc_index_one_node
);
4885 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4886 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4887 gfc_array_index_type
,
4889 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4890 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4891 gfc_array_index_type
,
4892 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4893 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4894 gfc_array_index_type
,
4895 tmp
, gfc_index_one_node
);
4896 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4897 gfc_array_index_type
, size
, tmp
);
4900 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4904 /* We want either the address for the data or the address of the descriptor,
4905 depending on the mode of passing array arguments. */
4907 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4909 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4911 /* Basically make this into
4922 pointer = parmse->expr;
4929 if (present && !contiguous)
4934 if (pass_optional
|| check_contiguous
)
4937 stmtblock_t else_block
;
4938 tree pre_stmts
, post_stmts
;
4941 tree present_var
= NULL_TREE
;
4942 tree cont_var
= NULL_TREE
;
4945 type
= TREE_TYPE (parmse
->expr
);
4946 pointer
= gfc_create_var (type
, "arg_ptr");
4948 if (check_contiguous
)
4950 gfc_se cont_se
, array_se
;
4951 stmtblock_t if_block
, else_block
;
4952 tree if_stmt
, else_stmt
;
4956 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
4958 /* If the size is known to be one at compile-time, set
4959 cont_var to true unconditionally. This may look
4960 inelegant, but we're only doing this during
4961 optimization, so the statements will be optimized away,
4962 and this saves complexity here. */
4964 size_set
= gfc_array_size (expr
, &size
);
4965 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
4967 gfc_add_modify (&se
->pre
, cont_var
,
4968 build_one_cst (boolean_type_node
));
4972 /* cont_var = is_contiguous (expr); . */
4973 gfc_init_se (&cont_se
, parmse
);
4974 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
4975 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
4976 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
4977 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
4983 /* arrayse->expr = descriptor of a. */
4984 gfc_init_se (&array_se
, se
);
4985 gfc_conv_expr_descriptor (&array_se
, expr
);
4986 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
4987 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
4989 /* if_stmt = { pointer = &a[0]; } . */
4990 gfc_init_block (&if_block
);
4991 tmp
= gfc_conv_array_data (array_se
.expr
);
4992 tmp
= fold_convert (type
, tmp
);
4993 gfc_add_modify (&if_block
, pointer
, tmp
);
4994 if_stmt
= gfc_finish_block (&if_block
);
4996 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
4997 gfc_init_block (&else_block
);
4998 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
4999 gfc_add_modify (&else_block
, pointer
, parmse
->expr
);
5000 else_stmt
= gfc_finish_block (&else_block
);
5002 /* And put the above into an if statement. */
5003 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5004 gfc_likely (cont_var
,
5005 PRED_FORTRAN_CONTIGUOUS
),
5006 if_stmt
, else_stmt
);
5010 /* pointer = pramse->expr; . */
5011 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5012 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5017 present_var
= gfc_create_var (boolean_type_node
, "present");
5019 /* present_var = present(sym); . */
5020 tmp
= gfc_conv_expr_present (sym
);
5021 tmp
= fold_convert (boolean_type_node
, tmp
);
5022 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5024 /* else_stmt = { pointer = NULL; } . */
5025 gfc_init_block (&else_block
);
5026 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5027 else_stmt
= gfc_finish_block (&else_block
);
5029 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5030 gfc_likely (present_var
,
5031 PRED_FORTRAN_ABSENT_DUMMY
),
5032 pre_stmts
, else_stmt
);
5033 gfc_add_expr_to_block (&se
->pre
, tmp
);
5036 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5038 post_stmts
= gfc_finish_block (&parmse
->post
);
5040 /* Put together the post stuff, plus the optional
5042 if (check_contiguous
)
5045 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5047 build_zero_cst (boolean_type_node
));
5048 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5052 tree present_likely
= gfc_likely (present_var
,
5053 PRED_FORTRAN_ABSENT_DUMMY
);
5054 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5055 boolean_type_node
, present_likely
,
5063 gcc_assert (pass_optional
);
5064 post_cond
= present_var
;
5067 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5068 post_stmts
, build_empty_stmt (input_location
));
5069 gfc_add_expr_to_block (&se
->post
, tmp
);
5077 /* Generate the code for argument list functions. */
5080 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5082 /* Pass by value for g77 %VAL(arg), pass the address
5083 indirectly for %LOC, else by reference. Thus %REF
5084 is a "do-nothing" and %LOC is the same as an F95
5086 if (strcmp (name
, "%VAL") == 0)
5087 gfc_conv_expr (se
, expr
);
5088 else if (strcmp (name
, "%LOC") == 0)
5090 gfc_conv_expr_reference (se
, expr
);
5091 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5093 else if (strcmp (name
, "%REF") == 0)
5094 gfc_conv_expr_reference (se
, expr
);
5096 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5100 /* This function tells whether the middle-end representation of the expression
5101 E given as input may point to data otherwise accessible through a variable
5103 It is assumed that the only expressions that may alias are variables,
5104 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5106 This function is used to decide whether freeing an expression's allocatable
5107 components is safe or should be avoided.
5109 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5110 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5111 is necessary because for array constructors, aliasing depends on how
5113 - If E is an array constructor used as argument to an elemental procedure,
5114 the array, which is generated through shallow copy by the scalarizer,
5115 is used directly and can alias the expressions it was copied from.
5116 - If E is an array constructor used as argument to a non-elemental
5117 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5118 the array as in the previous case, but then that array is used
5119 to initialize a new descriptor through deep copy. There is no alias
5120 possible in that case.
5121 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5125 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5129 if (e
->expr_type
== EXPR_VARIABLE
)
5131 else if (e
->expr_type
== EXPR_FUNCTION
)
5133 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5135 if (proc_ifc
->result
!= NULL
5136 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5137 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5138 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5139 || proc_ifc
->result
->attr
.pointer
))
5144 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5147 for (c
= gfc_constructor_first (e
->value
.constructor
);
5148 c
; c
= gfc_constructor_next (c
))
5150 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5157 /* A helper function to set the dtype for unallocated or unassociated
5161 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5169 /* TODO Figure out how to handle optional dummies. */
5170 if (e
&& e
->expr_type
== EXPR_VARIABLE
5171 && e
->symtree
->n
.sym
->attr
.optional
)
5174 desc
= parmse
->expr
;
5175 if (desc
== NULL_TREE
)
5178 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5179 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5181 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5184 gfc_init_block (&block
);
5185 tmp
= gfc_conv_descriptor_data_get (desc
);
5186 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5187 logical_type_node
, tmp
,
5188 build_int_cst (TREE_TYPE (tmp
), 0));
5189 tmp
= gfc_conv_descriptor_dtype (desc
);
5190 type
= gfc_get_element_type (TREE_TYPE (desc
));
5191 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5192 TREE_TYPE (tmp
), tmp
,
5193 gfc_get_dtype_rank_type (e
->rank
, type
));
5194 gfc_add_expr_to_block (&block
, tmp
);
5195 cond
= build3_v (COND_EXPR
, cond
,
5196 gfc_finish_block (&block
),
5197 build_empty_stmt (input_location
));
5198 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5203 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5204 ISO_Fortran_binding array descriptors. */
5207 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5217 symbol_attribute attr
= gfc_expr_attr (e
);
5219 /* If this is a full array or a scalar, the allocatable and pointer
5220 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5222 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
5226 else if (attr
.allocatable
)
5230 /* If the formal argument is assumed shape and neither a pointer nor
5231 allocatable, it is unconditionally CFI_attribute_other. */
5232 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
5233 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)
5236 cfi_attribute
= attribute
;
5240 parmse
->force_no_tmp
= 1;
5241 if (fsym
->attr
.contiguous
5242 && !gfc_is_simply_contiguous (e
, false, true))
5243 gfc_conv_subref_array_arg (parmse
, e
, false, fsym
->attr
.intent
,
5244 fsym
->attr
.pointer
);
5246 gfc_conv_expr_descriptor (parmse
, e
);
5248 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5249 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5251 bool is_artificial
= (INDIRECT_REF_P (parmse
->expr
)
5252 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse
->expr
, 0))
5253 : DECL_ARTIFICIAL (parmse
->expr
));
5255 /* Unallocated allocatable arrays and unassociated pointer arrays
5256 need their dtype setting if they are argument associated with
5257 assumed rank dummies. */
5258 if (fsym
&& fsym
->as
5259 && (gfc_expr_attr (e
).pointer
5260 || gfc_expr_attr (e
).allocatable
))
5261 set_dtype_for_unallocated (parmse
, e
);
5263 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5264 the expression type is different from the descriptor type, then
5265 the offset must be found (eg. to a component ref or substring)
5266 and the dtype updated. Assumed type entities are only allowed
5267 to be dummies in Fortran. They therefore lack the decl specific
5268 appendiges and so must be treated differently from other fortran
5269 entities passed to CFI descriptors in the interface decl. */
5270 type
= e
->ts
.type
!= BT_ASSUMED
? gfc_typenode_for_spec (&e
->ts
) :
5273 if (type
&& is_artificial
5274 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
5276 /* Obtain the offset to the data. */
5277 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
5278 gfc_index_zero_node
, true, e
);
5280 /* Update the dtype. */
5281 gfc_add_modify (&parmse
->pre
,
5282 gfc_conv_descriptor_dtype (parmse
->expr
),
5283 gfc_get_dtype_rank_type (e
->rank
, type
));
5285 else if (type
== NULL_TREE
5286 || (!is_subref_array (e
) && !is_artificial
))
5288 /* Make sure that the span is set for expressions where it
5289 might not have been done already. */
5290 tmp
= gfc_conv_descriptor_elem_len (parmse
->expr
);
5291 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5292 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
5297 gfc_conv_expr (parmse
, e
);
5299 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5300 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5303 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
5304 parmse
->expr
, attr
);
5307 /* Set the CFI attribute field through a temporary value for the
5309 desc_attr
= gfc_conv_descriptor_attribute (parmse
->expr
);
5310 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5311 void_type_node
, desc_attr
,
5312 build_int_cst (TREE_TYPE (desc_attr
), cfi_attribute
));
5313 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5315 /* Now pass the gfc_descriptor by reference. */
5316 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5318 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5319 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5320 gfc_desc_ptr
= parmse
->expr
;
5321 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
5322 gfc_add_modify (&parmse
->pre
, cfi_desc_ptr
, null_pointer_node
);
5324 /* Allocate the CFI descriptor itself and fill the fields. */
5325 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
5326 tmp
= build_call_expr_loc (input_location
,
5327 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
5328 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5330 /* Now set the gfc descriptor attribute. */
5331 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5332 void_type_node
, desc_attr
,
5333 build_int_cst (TREE_TYPE (desc_attr
), attribute
));
5334 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5336 /* The CFI descriptor is passed to the bind_C procedure. */
5337 parmse
->expr
= cfi_desc_ptr
;
5339 /* Free the CFI descriptor. */
5340 tmp
= gfc_call_free (cfi_desc_ptr
);
5341 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5343 /* Transfer values back to gfc descriptor. */
5344 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5345 tmp
= build_call_expr_loc (input_location
,
5346 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
5347 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5349 /* Deal with an optional dummy being passed to an optional formal arg
5350 by finishing the pre and post blocks and making their execution
5351 conditional on the dummy being present. */
5352 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5353 && e
->symtree
->n
.sym
->attr
.optional
)
5355 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5356 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5358 build_int_cst (pvoid_type_node
, 0));
5359 tmp
= build3_v (COND_EXPR
, cond
,
5360 gfc_finish_block (&parmse
->pre
), tmp
);
5361 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5362 tmp
= build3_v (COND_EXPR
, cond
,
5363 gfc_finish_block (&parmse
->post
),
5364 build_empty_stmt (input_location
));
5365 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5370 /* Generate code for a procedure call. Note can return se->post != NULL.
5371 If se->direct_byref is set then se->expr contains the return parameter.
5372 Return nonzero, if the call has alternate specifiers.
5373 'expr' is only needed for procedure pointer components. */
5376 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5377 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5378 vec
<tree
, va_gc
> *append_args
)
5380 gfc_interface_mapping mapping
;
5381 vec
<tree
, va_gc
> *arglist
;
5382 vec
<tree
, va_gc
> *retargs
;
5386 gfc_array_info
*info
;
5393 vec
<tree
, va_gc
> *stringargs
;
5394 vec
<tree
, va_gc
> *optionalargs
;
5396 gfc_formal_arglist
*formal
;
5397 gfc_actual_arglist
*arg
;
5398 int has_alternate_specifier
= 0;
5399 bool need_interface_mapping
;
5407 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5408 gfc_component
*comp
= NULL
;
5415 optionalargs
= NULL
;
5420 comp
= gfc_get_proc_ptr_comp (expr
);
5422 bool elemental_proc
= (comp
5423 && comp
->ts
.interface
5424 && comp
->ts
.interface
->attr
.elemental
)
5425 || (comp
&& comp
->attr
.elemental
)
5426 || sym
->attr
.elemental
;
5430 if (!elemental_proc
)
5432 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5433 if (se
->ss
->info
->useflags
)
5435 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5436 && sym
->result
->attr
.dimension
)
5437 || (comp
&& comp
->attr
.dimension
)
5438 || gfc_is_class_array_function (expr
));
5439 gcc_assert (se
->loop
!= NULL
);
5440 /* Access the previously obtained result. */
5441 gfc_conv_tmp_array_ref (se
);
5445 info
= &se
->ss
->info
->data
.array
;
5450 gfc_init_block (&post
);
5451 gfc_init_interface_mapping (&mapping
);
5454 formal
= gfc_sym_get_dummy_args (sym
);
5455 need_interface_mapping
= sym
->attr
.dimension
||
5456 (sym
->ts
.type
== BT_CHARACTER
5457 && sym
->ts
.u
.cl
->length
5458 && sym
->ts
.u
.cl
->length
->expr_type
5463 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5464 need_interface_mapping
= comp
->attr
.dimension
||
5465 (comp
->ts
.type
== BT_CHARACTER
5466 && comp
->ts
.u
.cl
->length
5467 && comp
->ts
.u
.cl
->length
->expr_type
5471 base_object
= NULL_TREE
;
5472 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5473 is the third and fourth argument to such a function call a value
5474 denoting the number of elements to copy (i.e., most of the time the
5475 length of a deferred length string). */
5476 ulim_copy
= (formal
== NULL
)
5477 && UNLIMITED_POLY (sym
)
5478 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5480 /* Evaluate the arguments. */
5481 for (arg
= args
, argc
= 0; arg
!= NULL
;
5482 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5484 bool finalized
= false;
5485 bool non_unity_length_string
= false;
5488 fsym
= formal
? formal
->sym
: NULL
;
5489 parm_kind
= MISSING
;
5491 if (fsym
&& fsym
->ts
.type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
5492 && (!fsym
->ts
.u
.cl
->length
5493 || fsym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5494 || mpz_cmp_si (fsym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5495 non_unity_length_string
= true;
5497 /* If the procedure requires an explicit interface, the actual
5498 argument is passed according to the corresponding formal
5499 argument. If the corresponding formal argument is a POINTER,
5500 ALLOCATABLE or assumed shape, we do not use g77's calling
5501 convention, and pass the address of the array descriptor
5502 instead. Otherwise we use g77's calling convention, in other words
5503 pass the array data pointer without descriptor. */
5504 bool nodesc_arg
= fsym
!= NULL
5505 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5507 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5508 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5510 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5512 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5514 /* Class array expressions are sometimes coming completely unadorned
5515 with either arrayspec or _data component. Correct that here.
5516 OOP-TODO: Move this to the frontend. */
5517 if (e
&& e
->expr_type
== EXPR_VARIABLE
5519 && e
->ts
.type
== BT_CLASS
5520 && (CLASS_DATA (e
)->attr
.codimension
5521 || CLASS_DATA (e
)->attr
.dimension
))
5523 gfc_typespec temp_ts
= e
->ts
;
5524 gfc_add_class_array_ref (e
);
5530 if (se
->ignore_optional
)
5532 /* Some intrinsics have already been resolved to the correct
5536 else if (arg
->label
)
5538 has_alternate_specifier
= 1;
5543 gfc_init_se (&parmse
, NULL
);
5545 /* For scalar arguments with VALUE attribute which are passed by
5546 value, pass "0" and a hidden argument gives the optional
5548 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5549 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5550 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5552 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5554 vec_safe_push (optionalargs
, boolean_false_node
);
5558 /* Pass a NULL pointer for an absent arg. */
5559 parmse
.expr
= null_pointer_node
;
5560 if (arg
->missing_arg_type
== BT_CHARACTER
)
5561 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5566 else if (arg
->expr
->expr_type
== EXPR_NULL
5567 && fsym
&& !fsym
->attr
.pointer
5568 && (fsym
->ts
.type
!= BT_CLASS
5569 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5571 /* Pass a NULL pointer to denote an absent arg. */
5572 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5573 && (fsym
->ts
.type
!= BT_CLASS
5574 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5575 gfc_init_se (&parmse
, NULL
);
5576 parmse
.expr
= null_pointer_node
;
5577 if (arg
->missing_arg_type
== BT_CHARACTER
)
5578 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5580 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5581 && e
->ts
.type
== BT_DERIVED
)
5583 /* The derived type needs to be converted to a temporary
5585 gfc_init_se (&parmse
, se
);
5586 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5588 && e
->expr_type
== EXPR_VARIABLE
5589 && e
->symtree
->n
.sym
->attr
.optional
,
5590 CLASS_DATA (fsym
)->attr
.class_pointer
5591 || CLASS_DATA (fsym
)->attr
.allocatable
);
5593 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
5595 /* The intrinsic type needs to be converted to a temporary
5596 CLASS object for the unlimited polymorphic formal. */
5597 gfc_init_se (&parmse
, se
);
5598 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5600 else if (se
->ss
&& se
->ss
->info
->useflags
)
5606 /* An elemental function inside a scalarized loop. */
5607 gfc_init_se (&parmse
, se
);
5608 parm_kind
= ELEMENTAL
;
5610 /* When no fsym is present, ulim_copy is set and this is a third or
5611 fourth argument, use call-by-value instead of by reference to
5612 hand the length properties to the copy routine (i.e., most of the
5613 time this will be a call to a __copy_character_* routine where the
5614 third and fourth arguments are the lengths of a deferred length
5616 if ((fsym
&& fsym
->attr
.value
)
5617 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5618 gfc_conv_expr (&parmse
, e
);
5620 gfc_conv_expr_reference (&parmse
, e
);
5622 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5623 && e
->expr_type
== EXPR_FUNCTION
)
5624 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5627 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5628 && gfc_is_class_container_ref (e
))
5630 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5632 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5633 && e
->symtree
->n
.sym
->attr
.optional
)
5635 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5636 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5637 TREE_TYPE (parmse
.expr
),
5639 fold_convert (TREE_TYPE (parmse
.expr
),
5640 null_pointer_node
));
5644 /* If we are passing an absent array as optional dummy to an
5645 elemental procedure, make sure that we pass NULL when the data
5646 pointer is NULL. We need this extra conditional because of
5647 scalarization which passes arrays elements to the procedure,
5648 ignoring the fact that the array can be absent/unallocated/... */
5649 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5651 tree descriptor_data
;
5653 descriptor_data
= ss
->info
->data
.array
.data
;
5654 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5656 fold_convert (TREE_TYPE (descriptor_data
),
5657 null_pointer_node
));
5659 = fold_build3_loc (input_location
, COND_EXPR
,
5660 TREE_TYPE (parmse
.expr
),
5661 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5662 fold_convert (TREE_TYPE (parmse
.expr
),
5667 /* The scalarizer does not repackage the reference to a class
5668 array - instead it returns a pointer to the data element. */
5669 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5670 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5671 fsym
->attr
.intent
!= INTENT_IN
5672 && (CLASS_DATA (fsym
)->attr
.class_pointer
5673 || CLASS_DATA (fsym
)->attr
.allocatable
),
5675 && e
->expr_type
== EXPR_VARIABLE
5676 && e
->symtree
->n
.sym
->attr
.optional
,
5677 CLASS_DATA (fsym
)->attr
.class_pointer
5678 || CLASS_DATA (fsym
)->attr
.allocatable
);
5685 gfc_init_se (&parmse
, NULL
);
5687 /* Check whether the expression is a scalar or not; we cannot use
5688 e->rank as it can be nonzero for functions arguments. */
5689 argss
= gfc_walk_expr (e
);
5690 scalar
= argss
== gfc_ss_terminator
;
5692 gfc_free_ss_chain (argss
);
5694 /* Special handling for passing scalar polymorphic coarrays;
5695 otherwise one passes "class->_data.data" instead of "&class". */
5696 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5697 && fsym
&& fsym
->ts
.type
== BT_CLASS
5698 && CLASS_DATA (fsym
)->attr
.codimension
5699 && !CLASS_DATA (fsym
)->attr
.dimension
)
5701 gfc_add_class_array_ref (e
);
5702 parmse
.want_coarray
= 1;
5706 /* A scalar or transformational function. */
5709 if (e
->expr_type
== EXPR_VARIABLE
5710 && e
->symtree
->n
.sym
->attr
.cray_pointee
5711 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5713 /* The Cray pointer needs to be converted to a pointer to
5714 a type given by the expression. */
5715 gfc_conv_expr (&parmse
, e
);
5716 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5717 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5718 parmse
.expr
= convert (type
, tmp
);
5721 else if (sym
->attr
.is_bind_c
&& e
5722 && (is_CFI_desc (fsym
, NULL
)
5723 || non_unity_length_string
))
5724 /* Implement F2018, C.12.6.1: paragraph (2). */
5725 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5727 else if (fsym
&& fsym
->attr
.value
)
5729 if (fsym
->ts
.type
== BT_CHARACTER
5730 && fsym
->ts
.is_c_interop
5731 && fsym
->ns
->proc_name
!= NULL
5732 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5735 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5736 if (parmse
.expr
== NULL
)
5737 gfc_conv_expr (&parmse
, e
);
5741 gfc_conv_expr (&parmse
, e
);
5742 if (fsym
->attr
.optional
5743 && fsym
->ts
.type
!= BT_CLASS
5744 && fsym
->ts
.type
!= BT_DERIVED
)
5746 if (e
->expr_type
!= EXPR_VARIABLE
5747 || !e
->symtree
->n
.sym
->attr
.optional
5749 vec_safe_push (optionalargs
, boolean_true_node
);
5752 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5753 if (!e
->symtree
->n
.sym
->attr
.value
)
5755 = fold_build3_loc (input_location
, COND_EXPR
,
5756 TREE_TYPE (parmse
.expr
),
5758 fold_convert (TREE_TYPE (parmse
.expr
),
5759 integer_zero_node
));
5761 vec_safe_push (optionalargs
,
5762 fold_convert (boolean_type_node
,
5769 else if (arg
->name
&& arg
->name
[0] == '%')
5770 /* Argument list functions %VAL, %LOC and %REF are signalled
5771 through arg->name. */
5772 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5773 else if ((e
->expr_type
== EXPR_FUNCTION
)
5774 && ((e
->value
.function
.esym
5775 && e
->value
.function
.esym
->result
->attr
.pointer
)
5776 || (!e
->value
.function
.esym
5777 && e
->symtree
->n
.sym
->attr
.pointer
))
5778 && fsym
&& fsym
->attr
.target
)
5780 gfc_conv_expr (&parmse
, e
);
5781 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5784 else if (e
->expr_type
== EXPR_FUNCTION
5785 && e
->symtree
->n
.sym
->result
5786 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5787 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5789 /* Functions returning procedure pointers. */
5790 gfc_conv_expr (&parmse
, e
);
5791 if (fsym
&& fsym
->attr
.proc_pointer
)
5792 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5797 if (e
->ts
.type
== BT_CLASS
&& fsym
5798 && fsym
->ts
.type
== BT_CLASS
5799 && (!CLASS_DATA (fsym
)->as
5800 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5801 && CLASS_DATA (e
)->attr
.codimension
)
5803 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5804 gcc_assert (!CLASS_DATA (fsym
)->as
);
5805 gfc_add_class_array_ref (e
);
5806 parmse
.want_coarray
= 1;
5807 gfc_conv_expr_reference (&parmse
, e
);
5808 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5810 && e
->expr_type
== EXPR_VARIABLE
);
5812 else if (e
->ts
.type
== BT_CLASS
&& fsym
5813 && fsym
->ts
.type
== BT_CLASS
5814 && !CLASS_DATA (fsym
)->as
5815 && !CLASS_DATA (e
)->as
5816 && strcmp (fsym
->ts
.u
.derived
->name
,
5817 e
->ts
.u
.derived
->name
))
5819 type
= gfc_typenode_for_spec (&fsym
->ts
);
5820 var
= gfc_create_var (type
, fsym
->name
);
5821 gfc_conv_expr (&parmse
, e
);
5822 if (fsym
->attr
.optional
5823 && e
->expr_type
== EXPR_VARIABLE
5824 && e
->symtree
->n
.sym
->attr
.optional
)
5828 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5829 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5830 logical_type_node
, tmp
,
5831 fold_convert (TREE_TYPE (tmp
),
5832 null_pointer_node
));
5833 gfc_start_block (&block
);
5834 gfc_add_modify (&block
, var
,
5835 fold_build1_loc (input_location
,
5837 type
, parmse
.expr
));
5838 gfc_add_expr_to_block (&parmse
.pre
,
5839 fold_build3_loc (input_location
,
5840 COND_EXPR
, void_type_node
,
5841 cond
, gfc_finish_block (&block
),
5842 build_empty_stmt (input_location
)));
5843 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5844 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5845 TREE_TYPE (parmse
.expr
),
5847 fold_convert (TREE_TYPE (parmse
.expr
),
5848 null_pointer_node
));
5852 /* Since the internal representation of unlimited
5853 polymorphic expressions includes an extra field
5854 that other class objects do not, a cast to the
5855 formal type does not work. */
5856 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5860 /* Set the _data field. */
5861 tmp
= gfc_class_data_get (var
);
5862 efield
= fold_convert (TREE_TYPE (tmp
),
5863 gfc_class_data_get (parmse
.expr
));
5864 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5866 /* Set the _vptr field. */
5867 tmp
= gfc_class_vptr_get (var
);
5868 efield
= fold_convert (TREE_TYPE (tmp
),
5869 gfc_class_vptr_get (parmse
.expr
));
5870 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5872 /* Set the _len field. */
5873 tmp
= gfc_class_len_get (var
);
5874 gfc_add_modify (&parmse
.pre
, tmp
,
5875 build_int_cst (TREE_TYPE (tmp
), 0));
5879 tmp
= fold_build1_loc (input_location
,
5882 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5885 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5891 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5892 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5893 && !e
->symtree
->n
.sym
->attr
.dimension
5894 && !e
->symtree
->n
.sym
->attr
.pointer
5896 && !e
->symtree
->n
.sym
->attr
.dummy
5897 /* FIXME - PR 87395 and PR 41453 */
5898 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5899 && !e
->symtree
->n
.sym
->attr
.associate_var
5900 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5901 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5903 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5905 /* Catch base objects that are not variables. */
5906 if (e
->ts
.type
== BT_CLASS
5907 && e
->expr_type
!= EXPR_VARIABLE
5908 && expr
&& e
== expr
->base_expr
)
5909 base_object
= build_fold_indirect_ref_loc (input_location
,
5912 /* A class array element needs converting back to be a
5913 class object, if the formal argument is a class object. */
5914 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5915 && e
->ts
.type
== BT_CLASS
5916 && ((CLASS_DATA (fsym
)->as
5917 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5918 || CLASS_DATA (e
)->attr
.dimension
))
5919 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5920 fsym
->attr
.intent
!= INTENT_IN
5921 && (CLASS_DATA (fsym
)->attr
.class_pointer
5922 || CLASS_DATA (fsym
)->attr
.allocatable
),
5924 && e
->expr_type
== EXPR_VARIABLE
5925 && e
->symtree
->n
.sym
->attr
.optional
,
5926 CLASS_DATA (fsym
)->attr
.class_pointer
5927 || CLASS_DATA (fsym
)->attr
.allocatable
);
5929 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5930 allocated on entry, it must be deallocated. */
5931 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5932 && (fsym
->attr
.allocatable
5933 || (fsym
->ts
.type
== BT_CLASS
5934 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5939 gfc_init_block (&block
);
5941 if (e
->ts
.type
== BT_CLASS
)
5942 ptr
= gfc_class_data_get (ptr
);
5944 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5947 gfc_add_expr_to_block (&block
, tmp
);
5948 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5949 void_type_node
, ptr
,
5951 gfc_add_expr_to_block (&block
, tmp
);
5953 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5955 gfc_add_modify (&block
, ptr
,
5956 fold_convert (TREE_TYPE (ptr
),
5957 null_pointer_node
));
5958 gfc_add_expr_to_block (&block
, tmp
);
5960 else if (fsym
->ts
.type
== BT_CLASS
)
5963 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5964 tmp
= gfc_get_symbol_decl (vtab
);
5965 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5966 ptr
= gfc_class_vptr_get (parmse
.expr
);
5967 gfc_add_modify (&block
, ptr
,
5968 fold_convert (TREE_TYPE (ptr
), tmp
));
5969 gfc_add_expr_to_block (&block
, tmp
);
5972 if (fsym
->attr
.optional
5973 && e
->expr_type
== EXPR_VARIABLE
5974 && e
->symtree
->n
.sym
->attr
.optional
)
5976 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5978 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5979 gfc_finish_block (&block
),
5980 build_empty_stmt (input_location
));
5983 tmp
= gfc_finish_block (&block
);
5985 gfc_add_expr_to_block (&se
->pre
, tmp
);
5988 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5989 || fsym
->ts
.type
== BT_ASSUMED
)
5990 && e
->ts
.type
== BT_CLASS
5991 && !CLASS_DATA (e
)->attr
.dimension
5992 && !CLASS_DATA (e
)->attr
.codimension
)
5994 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5995 /* The result is a class temporary, whose _data component
5996 must be freed to avoid a memory leak. */
5997 if (e
->expr_type
== EXPR_FUNCTION
5998 && CLASS_DATA (e
)->attr
.allocatable
)
6004 /* Borrow the function symbol to make a call to
6005 gfc_add_finalizer_call and then restore it. */
6006 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6007 e
->symtree
->n
.sym
->backend_decl
6008 = TREE_OPERAND (parmse
.expr
, 0);
6009 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6010 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6011 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6013 gfc_free_expr (var
);
6014 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6015 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6017 /* Then free the class _data. */
6018 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6019 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6022 tmp
= build3_v (COND_EXPR
, tmp
,
6023 gfc_call_free (parmse
.expr
),
6024 build_empty_stmt (input_location
));
6025 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6026 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6030 /* Wrap scalar variable in a descriptor. We need to convert
6031 the address of a pointer back to the pointer itself before,
6032 we can assign it to the data field. */
6034 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6035 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6038 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6039 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6040 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6042 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6045 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6046 && ((fsym
->attr
.pointer
6047 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6048 || (fsym
->attr
.proc_pointer
6049 && !(e
->expr_type
== EXPR_VARIABLE
6050 && e
->symtree
->n
.sym
->attr
.dummy
))
6051 || (fsym
->attr
.proc_pointer
6052 && e
->expr_type
== EXPR_VARIABLE
6053 && gfc_is_proc_ptr_comp (e
))
6054 || (fsym
->attr
.allocatable
6055 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6057 /* Scalar pointer dummy args require an extra level of
6058 indirection. The null pointer already contains
6059 this level of indirection. */
6060 parm_kind
= SCALAR_POINTER
;
6061 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6065 else if (e
->ts
.type
== BT_CLASS
6066 && fsym
&& fsym
->ts
.type
== BT_CLASS
6067 && (CLASS_DATA (fsym
)->attr
.dimension
6068 || CLASS_DATA (fsym
)->attr
.codimension
))
6070 /* Pass a class array. */
6071 parmse
.use_offset
= 1;
6072 gfc_conv_expr_descriptor (&parmse
, e
);
6074 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6075 allocated on entry, it must be deallocated. */
6076 if (fsym
->attr
.intent
== INTENT_OUT
6077 && CLASS_DATA (fsym
)->attr
.allocatable
)
6082 gfc_init_block (&block
);
6084 ptr
= gfc_class_data_get (ptr
);
6086 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6087 NULL_TREE
, NULL_TREE
,
6089 GFC_CAF_COARRAY_NOCOARRAY
);
6090 gfc_add_expr_to_block (&block
, tmp
);
6091 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6092 void_type_node
, ptr
,
6094 gfc_add_expr_to_block (&block
, tmp
);
6095 gfc_reset_vptr (&block
, e
);
6097 if (fsym
->attr
.optional
6098 && e
->expr_type
== EXPR_VARIABLE
6100 || (e
->ref
->type
== REF_ARRAY
6101 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6102 && e
->symtree
->n
.sym
->attr
.optional
)
6104 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6106 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6107 gfc_finish_block (&block
),
6108 build_empty_stmt (input_location
));
6111 tmp
= gfc_finish_block (&block
);
6113 gfc_add_expr_to_block (&se
->pre
, tmp
);
6116 /* The conversion does not repackage the reference to a class
6117 array - _data descriptor. */
6118 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6119 fsym
->attr
.intent
!= INTENT_IN
6120 && (CLASS_DATA (fsym
)->attr
.class_pointer
6121 || CLASS_DATA (fsym
)->attr
.allocatable
),
6123 && e
->expr_type
== EXPR_VARIABLE
6124 && e
->symtree
->n
.sym
->attr
.optional
,
6125 CLASS_DATA (fsym
)->attr
.class_pointer
6126 || CLASS_DATA (fsym
)->attr
.allocatable
);
6130 /* If the argument is a function call that may not create
6131 a temporary for the result, we have to check that we
6132 can do it, i.e. that there is no alias between this
6133 argument and another one. */
6134 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6140 intent
= fsym
->attr
.intent
;
6142 intent
= INTENT_UNKNOWN
;
6144 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6146 parmse
.force_tmp
= 1;
6148 iarg
= e
->value
.function
.actual
->expr
;
6150 /* Temporary needed if aliasing due to host association. */
6151 if (sym
->attr
.contained
6153 && !sym
->attr
.implicit_pure
6154 && !sym
->attr
.use_assoc
6155 && iarg
->expr_type
== EXPR_VARIABLE
6156 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6157 parmse
.force_tmp
= 1;
6159 /* Ditto within module. */
6160 if (sym
->attr
.use_assoc
6162 && !sym
->attr
.implicit_pure
6163 && iarg
->expr_type
== EXPR_VARIABLE
6164 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6165 parmse
.force_tmp
= 1;
6168 if (sym
->attr
.is_bind_c
&& e
6169 && (is_CFI_desc (fsym
, NULL
) || non_unity_length_string
))
6170 /* Implement F2018, C.12.6.1: paragraph (2). */
6171 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6173 else if (e
->expr_type
== EXPR_VARIABLE
6174 && is_subref_array (e
)
6175 && !(fsym
&& fsym
->attr
.pointer
))
6176 /* The actual argument is a component reference to an
6177 array of derived types. In this case, the argument
6178 is converted to a temporary, which is passed and then
6179 written back after the procedure call. */
6180 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6181 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6182 fsym
&& fsym
->attr
.pointer
);
6184 else if (gfc_is_class_array_ref (e
, NULL
)
6185 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6186 /* The actual argument is a component reference to an
6187 array of derived types. In this case, the argument
6188 is converted to a temporary, which is passed and then
6189 written back after the procedure call.
6190 OOP-TODO: Insert code so that if the dynamic type is
6191 the same as the declared type, copy-in/copy-out does
6193 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6195 fsym
->attr
.pointer
);
6197 else if (gfc_is_class_array_function (e
)
6198 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6199 /* See previous comment. For function actual argument,
6200 the write out is not needed so the intent is set as
6203 e
->must_finalize
= 1;
6204 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6205 INTENT_IN
, fsym
->attr
.pointer
);
6207 else if (fsym
&& fsym
->attr
.contiguous
6208 && !gfc_is_simply_contiguous (e
, false, true)
6209 && gfc_expr_is_variable (e
))
6211 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6213 fsym
->attr
.pointer
);
6216 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6219 /* Unallocated allocatable arrays and unassociated pointer arrays
6220 need their dtype setting if they are argument associated with
6221 assumed rank dummies. */
6222 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6223 && fsym
->as
->type
== AS_ASSUMED_RANK
)
6225 if (gfc_expr_attr (e
).pointer
6226 || gfc_expr_attr (e
).allocatable
)
6227 set_dtype_for_unallocated (&parmse
, e
);
6228 else if (e
->expr_type
== EXPR_VARIABLE
6229 && e
->symtree
->n
.sym
->attr
.dummy
6230 && e
->symtree
->n
.sym
->as
6231 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
6234 tmp
= build_fold_indirect_ref_loc (input_location
,
6236 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6237 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6238 gfc_rank_cst
[e
->rank
- 1],
6243 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6244 allocated on entry, it must be deallocated. */
6245 if (fsym
&& fsym
->attr
.allocatable
6246 && fsym
->attr
.intent
== INTENT_OUT
)
6248 if (fsym
->ts
.type
== BT_DERIVED
6249 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6251 // deallocate the components first
6252 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6253 parmse
.expr
, e
->rank
);
6254 if (tmp
!= NULL_TREE
)
6255 gfc_add_expr_to_block (&se
->pre
, tmp
);
6259 /* With bind(C), the actual argument is replaced by a bind-C
6260 descriptor; in this case, the data component arrives here,
6261 which shall not be dereferenced, but still freed and
6263 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6264 tmp
= build_fold_indirect_ref_loc (input_location
,
6266 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6267 tmp
= gfc_conv_descriptor_data_get (tmp
);
6268 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6269 NULL_TREE
, NULL_TREE
, true,
6271 GFC_CAF_COARRAY_NOCOARRAY
);
6272 if (fsym
->attr
.optional
6273 && e
->expr_type
== EXPR_VARIABLE
6274 && e
->symtree
->n
.sym
->attr
.optional
)
6275 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6277 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6278 tmp
, build_empty_stmt (input_location
));
6279 gfc_add_expr_to_block (&se
->pre
, tmp
);
6284 /* The case with fsym->attr.optional is that of a user subroutine
6285 with an interface indicating an optional argument. When we call
6286 an intrinsic subroutine, however, fsym is NULL, but we might still
6287 have an optional argument, so we proceed to the substitution
6289 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6291 /* If an optional argument is itself an optional dummy argument,
6292 check its presence and substitute a null if absent. This is
6293 only needed when passing an array to an elemental procedure
6294 as then array elements are accessed - or no NULL pointer is
6295 allowed and a "1" or "0" should be passed if not present.
6296 When passing a non-array-descriptor full array to a
6297 non-array-descriptor dummy, no check is needed. For
6298 array-descriptor actual to array-descriptor dummy, see
6299 PR 41911 for why a check has to be inserted.
6300 fsym == NULL is checked as intrinsics required the descriptor
6301 but do not always set fsym.
6302 Also, it is necessary to pass a NULL pointer to library routines
6303 which usually ignore optional arguments, so they can handle
6304 these themselves. */
6305 if (e
->expr_type
== EXPR_VARIABLE
6306 && e
->symtree
->n
.sym
->attr
.optional
6307 && (((e
->rank
!= 0 && elemental_proc
)
6308 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6312 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6313 || fsym
->as
->type
== AS_ASSUMED_RANK
6314 || fsym
->as
->type
== AS_DEFERRED
)))))
6315 || se
->ignore_optional
))
6316 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6317 e
->representation
.length
);
6322 /* Obtain the character length of an assumed character length
6323 length procedure from the typespec. */
6324 if (fsym
->ts
.type
== BT_CHARACTER
6325 && parmse
.string_length
== NULL_TREE
6326 && e
->ts
.type
== BT_PROCEDURE
6327 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6328 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6329 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6331 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6332 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6336 if (fsym
&& need_interface_mapping
&& e
)
6337 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6339 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6340 gfc_add_block_to_block (&post
, &parmse
.post
);
6342 /* Allocated allocatable components of derived types must be
6343 deallocated for non-variable scalars, array arguments to elemental
6344 procedures, and array arguments with descriptor to non-elemental
6345 procedures. As bounds information for descriptorless arrays is no
6346 longer available here, they are dealt with in trans-array.c
6347 (gfc_conv_array_parameter). */
6348 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
6349 && e
->ts
.u
.derived
->attr
.alloc_comp
6350 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
6351 && !expr_may_alias_variables (e
, elemental_proc
))
6354 /* It is known the e returns a structure type with at least one
6355 allocatable component. When e is a function, ensure that the
6356 function is called once only by using a temporary variable. */
6357 if (!DECL_P (parmse
.expr
))
6358 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
6359 parmse
.expr
, &se
->pre
);
6361 if (fsym
&& fsym
->attr
.value
)
6364 tmp
= build_fold_indirect_ref_loc (input_location
,
6367 parm_rank
= e
->rank
;
6375 case (SCALAR_POINTER
):
6376 tmp
= build_fold_indirect_ref_loc (input_location
,
6381 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
6383 /* The derived type is passed to gfc_deallocate_alloc_comp.
6384 Therefore, class actuals can be handled correctly but derived
6385 types passed to class formals need the _data component. */
6386 tmp
= gfc_class_data_get (tmp
);
6387 if (!CLASS_DATA (fsym
)->attr
.dimension
)
6388 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6391 if (e
->expr_type
== EXPR_OP
6392 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
6393 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
6396 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6397 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
6399 gfc_add_expr_to_block (&se
->post
, local_tmp
);
6402 if (!finalized
&& !e
->must_finalize
)
6404 if ((e
->ts
.type
== BT_CLASS
6405 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
6406 || e
->ts
.type
== BT_DERIVED
)
6407 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6409 else if (e
->ts
.type
== BT_CLASS
)
6410 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6412 gfc_prepend_expr_to_block (&post
, tmp
);
6416 /* Add argument checking of passing an unallocated/NULL actual to
6417 a nonallocatable/nonpointer dummy. */
6419 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6421 symbol_attribute attr
;
6425 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6426 attr
= gfc_expr_attr (e
);
6428 goto end_pointer_check
;
6430 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6431 allocatable to an optional dummy, cf. 12.5.2.12. */
6432 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6433 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6434 goto end_pointer_check
;
6438 /* If the actual argument is an optional pointer/allocatable and
6439 the formal argument takes an nonpointer optional value,
6440 it is invalid to pass a non-present argument on, even
6441 though there is no technical reason for this in gfortran.
6442 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6443 tree present
, null_ptr
, type
;
6445 if (attr
.allocatable
6446 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6447 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6448 "allocated or not present",
6449 e
->symtree
->n
.sym
->name
);
6450 else if (attr
.pointer
6451 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6452 msg
= xasprintf ("Pointer actual argument '%s' is not "
6453 "associated or not present",
6454 e
->symtree
->n
.sym
->name
);
6455 else if (attr
.proc_pointer
6456 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6457 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6458 "associated or not present",
6459 e
->symtree
->n
.sym
->name
);
6461 goto end_pointer_check
;
6463 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6464 type
= TREE_TYPE (present
);
6465 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6466 logical_type_node
, present
,
6468 null_pointer_node
));
6469 type
= TREE_TYPE (parmse
.expr
);
6470 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6471 logical_type_node
, parmse
.expr
,
6473 null_pointer_node
));
6474 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6475 logical_type_node
, present
, null_ptr
);
6479 if (attr
.allocatable
6480 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6481 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6482 "allocated", e
->symtree
->n
.sym
->name
);
6483 else if (attr
.pointer
6484 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6485 msg
= xasprintf ("Pointer actual argument '%s' is not "
6486 "associated", e
->symtree
->n
.sym
->name
);
6487 else if (attr
.proc_pointer
6488 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6489 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6490 "associated", e
->symtree
->n
.sym
->name
);
6492 goto end_pointer_check
;
6496 /* If the argument is passed by value, we need to strip the
6498 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6499 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6501 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6502 logical_type_node
, tmp
,
6503 fold_convert (TREE_TYPE (tmp
),
6504 null_pointer_node
));
6507 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6513 /* Deferred length dummies pass the character length by reference
6514 so that the value can be returned. */
6515 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6517 if (INDIRECT_REF_P (parmse
.string_length
))
6518 /* In chains of functions/procedure calls the string_length already
6519 is a pointer to the variable holding the length. Therefore
6520 remove the deref on call. */
6521 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6524 tmp
= parmse
.string_length
;
6525 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6526 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6527 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6531 /* Character strings are passed as two parameters, a length and a
6532 pointer - except for Bind(c) which only passes the pointer.
6533 An unlimited polymorphic formal argument likewise does not
6535 if (parmse
.string_length
!= NULL_TREE
6536 && !sym
->attr
.is_bind_c
6537 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6538 vec_safe_push (stringargs
, parmse
.string_length
);
6540 /* When calling __copy for character expressions to unlimited
6541 polymorphic entities, the dst argument needs a string length. */
6542 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6543 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6544 && arg
->next
&& arg
->next
->expr
6545 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6546 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6547 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6548 vec_safe_push (stringargs
, parmse
.string_length
);
6550 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6551 pass the token and the offset as additional arguments. */
6552 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6553 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6554 && !fsym
->attr
.allocatable
)
6555 || (fsym
->ts
.type
== BT_CLASS
6556 && CLASS_DATA (fsym
)->attr
.codimension
6557 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6559 /* Token and offset. */
6560 vec_safe_push (stringargs
, null_pointer_node
);
6561 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6562 gcc_assert (fsym
->attr
.optional
);
6564 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6565 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6566 && !fsym
->attr
.allocatable
)
6567 || (fsym
->ts
.type
== BT_CLASS
6568 && CLASS_DATA (fsym
)->attr
.codimension
6569 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6571 tree caf_decl
, caf_type
;
6574 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6575 caf_type
= TREE_TYPE (caf_decl
);
6577 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6578 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6579 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6580 tmp
= gfc_conv_descriptor_token (caf_decl
);
6581 else if (DECL_LANG_SPECIFIC (caf_decl
)
6582 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6583 tmp
= GFC_DECL_TOKEN (caf_decl
);
6586 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6587 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6588 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6591 vec_safe_push (stringargs
, tmp
);
6593 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6594 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6595 offset
= build_int_cst (gfc_array_index_type
, 0);
6596 else if (DECL_LANG_SPECIFIC (caf_decl
)
6597 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6598 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6599 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6600 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6602 offset
= build_int_cst (gfc_array_index_type
, 0);
6604 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6605 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6608 gcc_assert (POINTER_TYPE_P (caf_type
));
6612 tmp2
= fsym
->ts
.type
== BT_CLASS
6613 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6614 if ((fsym
->ts
.type
!= BT_CLASS
6615 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6616 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6617 || (fsym
->ts
.type
== BT_CLASS
6618 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6619 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6621 if (fsym
->ts
.type
== BT_CLASS
)
6622 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6625 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6626 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6628 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6629 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6631 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6632 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6635 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6638 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6639 gfc_array_index_type
,
6640 fold_convert (gfc_array_index_type
, tmp2
),
6641 fold_convert (gfc_array_index_type
, tmp
));
6642 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6643 gfc_array_index_type
, offset
, tmp
);
6645 vec_safe_push (stringargs
, offset
);
6648 vec_safe_push (arglist
, parmse
.expr
);
6650 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6654 else if (sym
->ts
.type
== BT_CLASS
)
6655 ts
= CLASS_DATA (sym
)->ts
;
6659 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6660 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6661 else if (ts
.type
== BT_CHARACTER
)
6663 if (ts
.u
.cl
->length
== NULL
)
6665 /* Assumed character length results are not allowed by C418 of the 2003
6666 standard and are trapped in resolve.c; except in the case of SPREAD
6667 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6668 we take the character length of the first argument for the result.
6669 For dummies, we have to look through the formal argument list for
6670 this function and use the character length found there.*/
6672 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6673 else if (!sym
->attr
.dummy
)
6674 cl
.backend_decl
= (*stringargs
)[0];
6677 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6678 for (; formal
; formal
= formal
->next
)
6679 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6680 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6682 len
= cl
.backend_decl
;
6688 /* Calculate the length of the returned string. */
6689 gfc_init_se (&parmse
, NULL
);
6690 if (need_interface_mapping
)
6691 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6693 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6694 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6695 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6697 /* TODO: It would be better to have the charlens as
6698 gfc_charlen_type_node already when the interface is
6699 created instead of converting it here (see PR 84615). */
6700 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6701 gfc_charlen_type_node
,
6702 fold_convert (gfc_charlen_type_node
, tmp
),
6703 build_zero_cst (gfc_charlen_type_node
));
6704 cl
.backend_decl
= tmp
;
6707 /* Set up a charlen structure for it. */
6712 len
= cl
.backend_decl
;
6715 byref
= (comp
&& (comp
->attr
.dimension
6716 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6717 || (!comp
&& gfc_return_by_reference (sym
));
6720 if (se
->direct_byref
)
6722 /* Sometimes, too much indirection can be applied; e.g. for
6723 function_result = array_valued_recursive_function. */
6724 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6725 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6726 && GFC_DESCRIPTOR_TYPE_P
6727 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6728 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6731 /* If the lhs of an assignment x = f(..) is allocatable and
6732 f2003 is allowed, we must do the automatic reallocation.
6733 TODO - deal with intrinsics, without using a temporary. */
6734 if (flag_realloc_lhs
6735 && se
->ss
&& se
->ss
->loop_chain
6736 && se
->ss
->loop_chain
->is_alloc_lhs
6737 && !expr
->value
.function
.isym
6738 && sym
->result
->as
!= NULL
)
6740 /* Evaluate the bounds of the result, if known. */
6741 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6744 /* Perform the automatic reallocation. */
6745 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6747 gfc_add_expr_to_block (&se
->pre
, tmp
);
6749 /* Pass the temporary as the first argument. */
6750 result
= info
->descriptor
;
6753 result
= build_fold_indirect_ref_loc (input_location
,
6755 vec_safe_push (retargs
, se
->expr
);
6757 else if (comp
&& comp
->attr
.dimension
)
6759 gcc_assert (se
->loop
&& info
);
6761 /* Set the type of the array. */
6762 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6763 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6765 /* Evaluate the bounds of the result, if known. */
6766 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6768 /* If the lhs of an assignment x = f(..) is allocatable and
6769 f2003 is allowed, we must not generate the function call
6770 here but should just send back the results of the mapping.
6771 This is signalled by the function ss being flagged. */
6772 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6774 gfc_free_interface_mapping (&mapping
);
6775 return has_alternate_specifier
;
6778 /* Create a temporary to store the result. In case the function
6779 returns a pointer, the temporary will be a shallow copy and
6780 mustn't be deallocated. */
6781 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6782 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6783 tmp
, NULL_TREE
, false,
6784 !comp
->attr
.pointer
, callee_alloc
,
6785 &se
->ss
->info
->expr
->where
);
6787 /* Pass the temporary as the first argument. */
6788 result
= info
->descriptor
;
6789 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6790 vec_safe_push (retargs
, tmp
);
6792 else if (!comp
&& sym
->result
->attr
.dimension
)
6794 gcc_assert (se
->loop
&& info
);
6796 /* Set the type of the array. */
6797 tmp
= gfc_typenode_for_spec (&ts
);
6798 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6800 /* Evaluate the bounds of the result, if known. */
6801 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6803 /* If the lhs of an assignment x = f(..) is allocatable and
6804 f2003 is allowed, we must not generate the function call
6805 here but should just send back the results of the mapping.
6806 This is signalled by the function ss being flagged. */
6807 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6809 gfc_free_interface_mapping (&mapping
);
6810 return has_alternate_specifier
;
6813 /* Create a temporary to store the result. In case the function
6814 returns a pointer, the temporary will be a shallow copy and
6815 mustn't be deallocated. */
6816 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6817 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6818 tmp
, NULL_TREE
, false,
6819 !sym
->attr
.pointer
, callee_alloc
,
6820 &se
->ss
->info
->expr
->where
);
6822 /* Pass the temporary as the first argument. */
6823 result
= info
->descriptor
;
6824 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6825 vec_safe_push (retargs
, tmp
);
6827 else if (ts
.type
== BT_CHARACTER
)
6829 /* Pass the string length. */
6830 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6831 type
= build_pointer_type (type
);
6833 /* Emit a DECL_EXPR for the VLA type. */
6834 tmp
= TREE_TYPE (type
);
6836 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6838 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6839 DECL_ARTIFICIAL (tmp
) = 1;
6840 DECL_IGNORED_P (tmp
) = 1;
6841 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6842 TREE_TYPE (tmp
), tmp
);
6843 gfc_add_expr_to_block (&se
->pre
, tmp
);
6846 /* Return an address to a char[0:len-1]* temporary for
6847 character pointers. */
6848 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6849 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6851 var
= gfc_create_var (type
, "pstr");
6853 if ((!comp
&& sym
->attr
.allocatable
)
6854 || (comp
&& comp
->attr
.allocatable
))
6856 gfc_add_modify (&se
->pre
, var
,
6857 fold_convert (TREE_TYPE (var
),
6858 null_pointer_node
));
6859 tmp
= gfc_call_free (var
);
6860 gfc_add_expr_to_block (&se
->post
, tmp
);
6863 /* Provide an address expression for the function arguments. */
6864 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6867 var
= gfc_conv_string_tmp (se
, type
, len
);
6869 vec_safe_push (retargs
, var
);
6873 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6875 type
= gfc_get_complex_type (ts
.kind
);
6876 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6877 vec_safe_push (retargs
, var
);
6880 /* Add the string length to the argument list. */
6881 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6885 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6886 TREE_STATIC (tmp
) = 1;
6887 gfc_add_modify (&se
->pre
, tmp
,
6888 build_int_cst (TREE_TYPE (tmp
), 0));
6889 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6890 vec_safe_push (retargs
, tmp
);
6892 else if (ts
.type
== BT_CHARACTER
)
6893 vec_safe_push (retargs
, len
);
6895 gfc_free_interface_mapping (&mapping
);
6897 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6898 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6899 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6900 vec_safe_reserve (retargs
, arglen
);
6902 /* Add the return arguments. */
6903 vec_safe_splice (retargs
, arglist
);
6905 /* Add the hidden present status for optional+value to the arguments. */
6906 vec_safe_splice (retargs
, optionalargs
);
6908 /* Add the hidden string length parameters to the arguments. */
6909 vec_safe_splice (retargs
, stringargs
);
6911 /* We may want to append extra arguments here. This is used e.g. for
6912 calls to libgfortran_matmul_??, which need extra information. */
6913 vec_safe_splice (retargs
, append_args
);
6917 /* Generate the actual call. */
6918 if (base_object
== NULL_TREE
)
6919 conv_function_val (se
, sym
, expr
, args
);
6921 conv_base_obj_fcn_val (se
, base_object
, expr
);
6923 /* If there are alternate return labels, function type should be
6924 integer. Can't modify the type in place though, since it can be shared
6925 with other functions. For dummy arguments, the typing is done to
6926 this result, even if it has to be repeated for each call. */
6927 if (has_alternate_specifier
6928 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6930 if (!sym
->attr
.dummy
)
6932 TREE_TYPE (sym
->backend_decl
)
6933 = build_function_type (integer_type_node
,
6934 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6935 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6938 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6941 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6942 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6944 /* Allocatable scalar function results must be freed and nullified
6945 after use. This necessitates the creation of a temporary to
6946 hold the result to prevent duplicate calls. */
6947 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6948 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6949 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6951 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6952 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6954 tmp
= gfc_call_free (tmp
);
6955 gfc_add_expr_to_block (&post
, tmp
);
6956 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6959 /* If we have a pointer function, but we don't want a pointer, e.g.
6962 where f is pointer valued, we have to dereference the result. */
6963 if (!se
->want_pointer
&& !byref
6964 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6965 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6966 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6968 /* f2c calling conventions require a scalar default real function to
6969 return a double precision result. Convert this back to default
6970 real. We only care about the cases that can happen in Fortran 77.
6972 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6973 && sym
->ts
.kind
== gfc_default_real_kind
6974 && !sym
->attr
.always_explicit
)
6975 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6977 /* A pure function may still have side-effects - it may modify its
6979 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6981 if (!sym
->attr
.pure
)
6982 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6987 /* Add the function call to the pre chain. There is no expression. */
6988 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6989 se
->expr
= NULL_TREE
;
6991 if (!se
->direct_byref
)
6993 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6995 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6997 /* Check the data pointer hasn't been modified. This would
6998 happen in a function returning a pointer. */
6999 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7000 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7003 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7006 se
->expr
= info
->descriptor
;
7007 /* Bundle in the string length. */
7008 se
->string_length
= len
;
7010 else if (ts
.type
== BT_CHARACTER
)
7012 /* Dereference for character pointer results. */
7013 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7014 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7015 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7019 se
->string_length
= len
;
7023 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7024 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7029 /* Associate the rhs class object's meta-data with the result, when the
7030 result is a temporary. */
7031 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7032 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7033 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7036 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7038 gfc_init_se (&parmse
, NULL
);
7039 parmse
.data_not_needed
= 1;
7040 gfc_conv_expr (&parmse
, class_expr
);
7041 if (!DECL_LANG_SPECIFIC (result
))
7042 gfc_allocate_lang_decl (result
);
7043 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7044 gfc_free_expr (class_expr
);
7045 /* -fcheck= can add diagnostic code, which has to be placed before
7047 if (parmse
.pre
.head
!= NULL
)
7048 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7049 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7052 /* Follow the function call with the argument post block. */
7055 gfc_add_block_to_block (&se
->pre
, &post
);
7057 /* Transformational functions of derived types with allocatable
7058 components must have the result allocatable components copied when the
7059 argument is actually given. */
7060 arg
= expr
->value
.function
.actual
;
7061 if (result
&& arg
&& expr
->rank
7062 && expr
->value
.function
.isym
7063 && expr
->value
.function
.isym
->transformational
7065 && arg
->expr
->ts
.type
== BT_DERIVED
7066 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7069 /* Copy the allocatable components. We have to use a
7070 temporary here to prevent source allocatable components
7071 from being corrupted. */
7072 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7073 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7074 result
, tmp2
, expr
->rank
, 0);
7075 gfc_add_expr_to_block (&se
->pre
, tmp
);
7076 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7078 gfc_add_expr_to_block (&se
->pre
, tmp
);
7080 /* Finally free the temporary's data field. */
7081 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7082 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7083 NULL_TREE
, NULL_TREE
, true,
7084 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7085 gfc_add_expr_to_block (&se
->pre
, tmp
);
7090 /* For a function with a class array result, save the result as
7091 a temporary, set the info fields needed by the scalarizer and
7092 call the finalization function of the temporary. Note that the
7093 nullification of allocatable components needed by the result
7094 is done in gfc_trans_assignment_1. */
7095 if (expr
&& ((gfc_is_class_array_function (expr
)
7096 && se
->ss
&& se
->ss
->loop
)
7097 || gfc_is_alloc_class_scalar_function (expr
))
7098 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7099 && expr
->must_finalize
)
7104 if (se
->ss
&& se
->ss
->loop
)
7106 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7107 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7108 tmp
= gfc_class_data_get (se
->expr
);
7109 info
->descriptor
= tmp
;
7110 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7111 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7112 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7114 tree dim
= gfc_rank_cst
[n
];
7115 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7116 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7121 /* TODO Eliminate the doubling of temporaries. This
7122 one is necessary to ensure no memory leakage. */
7123 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7124 tmp
= gfc_class_data_get (se
->expr
);
7125 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7126 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7129 if ((gfc_is_class_array_function (expr
)
7130 || gfc_is_alloc_class_scalar_function (expr
))
7131 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7132 goto no_finalization
;
7134 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7135 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7138 fold_convert (TREE_TYPE (final_fndecl
),
7139 null_pointer_node
));
7140 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7142 tmp
= build_call_expr_loc (input_location
,
7144 gfc_build_addr_expr (NULL
, tmp
),
7145 gfc_class_vtab_size_get (se
->expr
),
7146 boolean_false_node
);
7147 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7148 void_type_node
, is_final
, tmp
,
7149 build_empty_stmt (input_location
));
7151 if (se
->ss
&& se
->ss
->loop
)
7153 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7154 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7157 fold_convert (TREE_TYPE (info
->data
),
7158 null_pointer_node
));
7159 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7160 void_type_node
, tmp
,
7161 gfc_call_free (info
->data
),
7162 build_empty_stmt (input_location
));
7163 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7168 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7169 classdata
= gfc_class_data_get (se
->expr
);
7170 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7173 fold_convert (TREE_TYPE (classdata
),
7174 null_pointer_node
));
7175 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7176 void_type_node
, tmp
,
7177 gfc_call_free (classdata
),
7178 build_empty_stmt (input_location
));
7179 gfc_add_expr_to_block (&se
->post
, tmp
);
7184 gfc_add_block_to_block (&se
->post
, &post
);
7187 return has_alternate_specifier
;
7191 /* Fill a character string with spaces. */
7194 fill_with_spaces (tree start
, tree type
, tree size
)
7196 stmtblock_t block
, loop
;
7197 tree i
, el
, exit_label
, cond
, tmp
;
7199 /* For a simple char type, we can call memset(). */
7200 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7201 return build_call_expr_loc (input_location
,
7202 builtin_decl_explicit (BUILT_IN_MEMSET
),
7204 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7205 lang_hooks
.to_target_charset (' ')),
7206 fold_convert (size_type_node
, size
));
7208 /* Otherwise, we use a loop:
7209 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7213 /* Initialize variables. */
7214 gfc_init_block (&block
);
7215 i
= gfc_create_var (sizetype
, "i");
7216 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7217 el
= gfc_create_var (build_pointer_type (type
), "el");
7218 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7219 exit_label
= gfc_build_label_decl (NULL_TREE
);
7220 TREE_USED (exit_label
) = 1;
7224 gfc_init_block (&loop
);
7226 /* Exit condition. */
7227 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7228 build_zero_cst (sizetype
));
7229 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7230 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7231 build_empty_stmt (input_location
));
7232 gfc_add_expr_to_block (&loop
, tmp
);
7235 gfc_add_modify (&loop
,
7236 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7237 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7239 /* Increment loop variables. */
7240 gfc_add_modify (&loop
, i
,
7241 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7242 TYPE_SIZE_UNIT (type
)));
7243 gfc_add_modify (&loop
, el
,
7244 fold_build_pointer_plus_loc (input_location
,
7245 el
, TYPE_SIZE_UNIT (type
)));
7247 /* Making the loop... actually loop! */
7248 tmp
= gfc_finish_block (&loop
);
7249 tmp
= build1_v (LOOP_EXPR
, tmp
);
7250 gfc_add_expr_to_block (&block
, tmp
);
7252 /* The exit label. */
7253 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7254 gfc_add_expr_to_block (&block
, tmp
);
7257 return gfc_finish_block (&block
);
7261 /* Generate code to copy a string. */
7264 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7265 int dkind
, tree slength
, tree src
, int skind
)
7267 tree tmp
, dlen
, slen
;
7276 stmtblock_t tempblock
;
7278 gcc_assert (dkind
== skind
);
7280 if (slength
!= NULL_TREE
)
7282 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7283 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
7287 slen
= build_one_cst (gfc_charlen_type_node
);
7291 if (dlength
!= NULL_TREE
)
7293 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
7294 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
7298 dlen
= build_one_cst (gfc_charlen_type_node
);
7302 /* Assign directly if the types are compatible. */
7303 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
7304 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
7306 gfc_add_modify (block
, dsc
, ssc
);
7310 /* The string copy algorithm below generates code like
7314 if (srclen < destlen)
7316 memmove (dest, src, srclen);
7318 memset (&dest[srclen], ' ', destlen - srclen);
7322 // Truncate if too long.
7323 memmove (dest, src, destlen);
7328 /* Do nothing if the destination length is zero. */
7329 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
7330 build_zero_cst (TREE_TYPE (dlen
)));
7332 /* For non-default character kinds, we have to multiply the string
7333 length by the base type size. */
7334 chartype
= gfc_get_char_type (dkind
);
7335 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
7337 fold_convert (TREE_TYPE (slen
),
7338 TYPE_SIZE_UNIT (chartype
)));
7339 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
7341 fold_convert (TREE_TYPE (dlen
),
7342 TYPE_SIZE_UNIT (chartype
)));
7344 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
7345 dest
= fold_convert (pvoid_type_node
, dest
);
7347 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
7349 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
7350 src
= fold_convert (pvoid_type_node
, src
);
7352 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7354 /* Truncate string if source is too long. */
7355 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
7358 /* Copy and pad with spaces. */
7359 tmp3
= build_call_expr_loc (input_location
,
7360 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7362 fold_convert (size_type_node
, slen
));
7364 /* Wstringop-overflow appears at -O3 even though this warning is not
7365 explicitly available in fortran nor can it be switched off. If the
7366 source length is a constant, its negative appears as a very large
7367 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7368 the result of the MINUS_EXPR suppresses this spurious warning. */
7369 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7370 TREE_TYPE(dlen
), dlen
, slen
);
7371 if (slength
&& TREE_CONSTANT (slength
))
7372 tmp
= gfc_evaluate_now (tmp
, block
);
7374 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
7375 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
7377 gfc_init_block (&tempblock
);
7378 gfc_add_expr_to_block (&tempblock
, tmp3
);
7379 gfc_add_expr_to_block (&tempblock
, tmp4
);
7380 tmp3
= gfc_finish_block (&tempblock
);
7382 /* The truncated memmove if the slen >= dlen. */
7383 tmp2
= build_call_expr_loc (input_location
,
7384 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7386 fold_convert (size_type_node
, dlen
));
7388 /* The whole copy_string function is there. */
7389 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
7391 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7392 build_empty_stmt (input_location
));
7393 gfc_add_expr_to_block (block
, tmp
);
7397 /* Translate a statement function.
7398 The value of a statement function reference is obtained by evaluating the
7399 expression using the values of the actual arguments for the values of the
7400 corresponding dummy arguments. */
7403 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
7407 gfc_formal_arglist
*fargs
;
7408 gfc_actual_arglist
*args
;
7411 gfc_saved_var
*saved_vars
;
7417 sym
= expr
->symtree
->n
.sym
;
7418 args
= expr
->value
.function
.actual
;
7419 gfc_init_se (&lse
, NULL
);
7420 gfc_init_se (&rse
, NULL
);
7423 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7425 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7426 temp_vars
= XCNEWVEC (tree
, n
);
7428 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7429 fargs
= fargs
->next
, n
++)
7431 /* Each dummy shall be specified, explicitly or implicitly, to be
7433 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7436 if (fsym
->ts
.type
== BT_CHARACTER
)
7438 /* Copy string arguments. */
7441 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7442 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7444 /* Create a temporary to hold the value. */
7445 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7446 fsym
->ts
.u
.cl
->backend_decl
7447 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7449 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7450 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7452 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7454 gfc_conv_expr (&rse
, args
->expr
);
7455 gfc_conv_string_parameter (&rse
);
7456 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7457 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7459 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7460 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7461 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7462 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7466 /* For everything else, just evaluate the expression. */
7468 /* Create a temporary to hold the value. */
7469 type
= gfc_typenode_for_spec (&fsym
->ts
);
7470 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7472 gfc_conv_expr (&lse
, args
->expr
);
7474 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7475 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7476 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7482 /* Use the temporary variables in place of the real ones. */
7483 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7484 fargs
= fargs
->next
, n
++)
7485 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7487 gfc_conv_expr (se
, sym
->value
);
7489 if (sym
->ts
.type
== BT_CHARACTER
)
7491 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7493 /* Force the expression to the correct length. */
7494 if (!INTEGER_CST_P (se
->string_length
)
7495 || tree_int_cst_lt (se
->string_length
,
7496 sym
->ts
.u
.cl
->backend_decl
))
7498 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7499 tmp
= gfc_create_var (type
, sym
->name
);
7500 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7501 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7502 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7506 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7509 /* Restore the original variables. */
7510 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7511 fargs
= fargs
->next
, n
++)
7512 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7518 /* Translate a function expression. */
7521 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7525 if (expr
->value
.function
.isym
)
7527 gfc_conv_intrinsic_function (se
, expr
);
7531 /* expr.value.function.esym is the resolved (specific) function symbol for
7532 most functions. However this isn't set for dummy procedures. */
7533 sym
= expr
->value
.function
.esym
;
7535 sym
= expr
->symtree
->n
.sym
;
7537 /* The IEEE_ARITHMETIC functions are caught here. */
7538 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7539 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7542 /* We distinguish statement functions from general functions to improve
7543 runtime performance. */
7544 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7546 gfc_conv_statement_function (se
, expr
);
7550 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7555 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7558 is_zero_initializer_p (gfc_expr
* expr
)
7560 if (expr
->expr_type
!= EXPR_CONSTANT
)
7563 /* We ignore constants with prescribed memory representations for now. */
7564 if (expr
->representation
.string
)
7567 switch (expr
->ts
.type
)
7570 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7573 return mpfr_zero_p (expr
->value
.real
)
7574 && MPFR_SIGN (expr
->value
.real
) >= 0;
7577 return expr
->value
.logical
== 0;
7580 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7581 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7582 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7583 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7593 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7598 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7599 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7601 gfc_conv_tmp_array_ref (se
);
7605 /* Build a static initializer. EXPR is the expression for the initial value.
7606 The other parameters describe the variable of the component being
7607 initialized. EXPR may be null. */
7610 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7611 bool array
, bool pointer
, bool procptr
)
7615 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7616 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7617 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7618 return build_constructor (type
, NULL
);
7620 if (!(expr
|| pointer
|| procptr
))
7623 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7624 (these are the only two iso_c_binding derived types that can be
7625 used as initialization expressions). If so, we need to modify
7626 the 'expr' to be that for a (void *). */
7627 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7628 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7630 if (TREE_CODE (type
) == ARRAY_TYPE
)
7631 return build_constructor (type
, NULL
);
7632 else if (POINTER_TYPE_P (type
))
7633 return build_int_cst (type
, 0);
7638 if (array
&& !procptr
)
7641 /* Arrays need special handling. */
7643 ctor
= gfc_build_null_descriptor (type
);
7644 /* Special case assigning an array to zero. */
7645 else if (is_zero_initializer_p (expr
))
7646 ctor
= build_constructor (type
, NULL
);
7648 ctor
= gfc_conv_array_initializer (type
, expr
);
7649 TREE_STATIC (ctor
) = 1;
7652 else if (pointer
|| procptr
)
7654 if (ts
->type
== BT_CLASS
&& !procptr
)
7656 gfc_init_se (&se
, NULL
);
7657 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7658 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7659 TREE_STATIC (se
.expr
) = 1;
7662 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7663 return fold_convert (type
, null_pointer_node
);
7666 gfc_init_se (&se
, NULL
);
7667 se
.want_pointer
= 1;
7668 gfc_conv_expr (&se
, expr
);
7669 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7679 gfc_init_se (&se
, NULL
);
7680 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7681 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7683 gfc_conv_structure (&se
, expr
, 1);
7684 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7685 TREE_STATIC (se
.expr
) = 1;
7690 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
7691 TREE_STATIC (ctor
) = 1;
7696 gfc_init_se (&se
, NULL
);
7697 gfc_conv_constant (&se
, expr
);
7698 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7705 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7711 gfc_array_info
*lss_array
;
7718 gfc_start_block (&block
);
7720 /* Initialize the scalarizer. */
7721 gfc_init_loopinfo (&loop
);
7723 gfc_init_se (&lse
, NULL
);
7724 gfc_init_se (&rse
, NULL
);
7727 rss
= gfc_walk_expr (expr
);
7728 if (rss
== gfc_ss_terminator
)
7729 /* The rhs is scalar. Add a ss for the expression. */
7730 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7732 /* Create a SS for the destination. */
7733 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7735 lss_array
= &lss
->info
->data
.array
;
7736 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7737 lss_array
->descriptor
= dest
;
7738 lss_array
->data
= gfc_conv_array_data (dest
);
7739 lss_array
->offset
= gfc_conv_array_offset (dest
);
7740 for (n
= 0; n
< cm
->as
->rank
; n
++)
7742 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7743 lss_array
->stride
[n
] = gfc_index_one_node
;
7745 mpz_init (lss_array
->shape
[n
]);
7746 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7747 cm
->as
->lower
[n
]->value
.integer
);
7748 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7751 /* Associate the SS with the loop. */
7752 gfc_add_ss_to_loop (&loop
, lss
);
7753 gfc_add_ss_to_loop (&loop
, rss
);
7755 /* Calculate the bounds of the scalarization. */
7756 gfc_conv_ss_startstride (&loop
);
7758 /* Setup the scalarizing loops. */
7759 gfc_conv_loop_setup (&loop
, &expr
->where
);
7761 /* Setup the gfc_se structures. */
7762 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7763 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7766 gfc_mark_ss_chain_used (rss
, 1);
7768 gfc_mark_ss_chain_used (lss
, 1);
7770 /* Start the scalarized loop body. */
7771 gfc_start_scalarized_body (&loop
, &body
);
7773 gfc_conv_tmp_array_ref (&lse
);
7774 if (cm
->ts
.type
== BT_CHARACTER
)
7775 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7777 gfc_conv_expr (&rse
, expr
);
7779 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7780 gfc_add_expr_to_block (&body
, tmp
);
7782 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7784 /* Generate the copying loops. */
7785 gfc_trans_scalarizing_loops (&loop
, &body
);
7787 /* Wrap the whole thing up. */
7788 gfc_add_block_to_block (&block
, &loop
.pre
);
7789 gfc_add_block_to_block (&block
, &loop
.post
);
7791 gcc_assert (lss_array
->shape
!= NULL
);
7792 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7793 gfc_cleanup_loop (&loop
);
7795 return gfc_finish_block (&block
);
7800 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7810 gfc_expr
*arg
= NULL
;
7812 gfc_start_block (&block
);
7813 gfc_init_se (&se
, NULL
);
7815 /* Get the descriptor for the expressions. */
7816 se
.want_pointer
= 0;
7817 gfc_conv_expr_descriptor (&se
, expr
);
7818 gfc_add_block_to_block (&block
, &se
.pre
);
7819 gfc_add_modify (&block
, dest
, se
.expr
);
7821 /* Deal with arrays of derived types with allocatable components. */
7822 if (gfc_bt_struct (cm
->ts
.type
)
7823 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7824 // TODO: Fix caf_mode
7825 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7828 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7829 && CLASS_DATA(cm
)->attr
.allocatable
)
7831 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7832 // TODO: Fix caf_mode
7833 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7838 tmp
= TREE_TYPE (dest
);
7839 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7840 tmp
, expr
->rank
, NULL_TREE
);
7844 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7845 TREE_TYPE(cm
->backend_decl
),
7846 cm
->as
->rank
, NULL_TREE
);
7848 gfc_add_expr_to_block (&block
, tmp
);
7849 gfc_add_block_to_block (&block
, &se
.post
);
7851 if (expr
->expr_type
!= EXPR_VARIABLE
)
7852 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7855 /* We need to know if the argument of a conversion function is a
7856 variable, so that the correct lower bound can be used. */
7857 if (expr
->expr_type
== EXPR_FUNCTION
7858 && expr
->value
.function
.isym
7859 && expr
->value
.function
.isym
->conversion
7860 && expr
->value
.function
.actual
->expr
7861 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7862 arg
= expr
->value
.function
.actual
->expr
;
7864 /* Obtain the array spec of full array references. */
7866 as
= gfc_get_full_arrayspec_from_expr (arg
);
7868 as
= gfc_get_full_arrayspec_from_expr (expr
);
7870 /* Shift the lbound and ubound of temporaries to being unity,
7871 rather than zero, based. Always calculate the offset. */
7872 offset
= gfc_conv_descriptor_offset_get (dest
);
7873 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7874 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7876 for (n
= 0; n
< expr
->rank
; n
++)
7881 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7882 TODO It looks as if gfc_conv_expr_descriptor should return
7883 the correct bounds and that the following should not be
7884 necessary. This would simplify gfc_conv_intrinsic_bound
7886 if (as
&& as
->lower
[n
])
7889 gfc_init_se (&lbse
, NULL
);
7890 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7891 gfc_add_block_to_block (&block
, &lbse
.pre
);
7892 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7896 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7897 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7901 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7904 lbound
= gfc_index_one_node
;
7906 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7908 /* Shift the bounds and set the offset accordingly. */
7909 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7910 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7911 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7912 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7914 gfc_conv_descriptor_ubound_set (&block
, dest
,
7915 gfc_rank_cst
[n
], tmp
);
7916 gfc_conv_descriptor_lbound_set (&block
, dest
,
7917 gfc_rank_cst
[n
], lbound
);
7919 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7920 gfc_conv_descriptor_lbound_get (dest
,
7922 gfc_conv_descriptor_stride_get (dest
,
7924 gfc_add_modify (&block
, tmp2
, tmp
);
7925 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7927 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7932 /* If a conversion expression has a null data pointer
7933 argument, nullify the allocatable component. */
7937 if (arg
->symtree
->n
.sym
->attr
.allocatable
7938 || arg
->symtree
->n
.sym
->attr
.pointer
)
7940 non_null_expr
= gfc_finish_block (&block
);
7941 gfc_start_block (&block
);
7942 gfc_conv_descriptor_data_set (&block
, dest
,
7944 null_expr
= gfc_finish_block (&block
);
7945 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7946 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7947 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7948 return build3_v (COND_EXPR
, tmp
,
7949 null_expr
, non_null_expr
);
7953 return gfc_finish_block (&block
);
7957 /* Allocate or reallocate scalar component, as necessary. */
7960 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7970 tree lhs_cl_size
= NULL_TREE
;
7975 if (!expr2
|| expr2
->rank
)
7978 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7980 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7982 char name
[GFC_MAX_SYMBOL_LEN
+9];
7983 gfc_component
*strlen
;
7984 /* Use the rhs string length and the lhs element size. */
7985 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7986 if (!expr2
->ts
.u
.cl
->backend_decl
)
7988 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7989 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7992 size
= expr2
->ts
.u
.cl
->backend_decl
;
7994 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7996 sprintf (name
, "_%s_length", cm
->name
);
7997 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7998 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7999 gfc_charlen_type_node
,
8000 TREE_OPERAND (comp
, 0),
8001 strlen
->backend_decl
, NULL_TREE
);
8003 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8004 tmp
= TYPE_SIZE_UNIT (tmp
);
8005 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8006 TREE_TYPE (tmp
), tmp
,
8007 fold_convert (TREE_TYPE (tmp
), size
));
8009 else if (cm
->ts
.type
== BT_CLASS
)
8011 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8012 if (expr2
->ts
.type
== BT_DERIVED
)
8014 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8015 size
= TYPE_SIZE_UNIT (tmp
);
8021 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8022 gfc_add_vptr_component (e2vtab
);
8023 gfc_add_size_component (e2vtab
);
8024 gfc_init_se (&se
, NULL
);
8025 gfc_conv_expr (&se
, e2vtab
);
8026 gfc_add_block_to_block (block
, &se
.pre
);
8027 size
= fold_convert (size_type_node
, se
.expr
);
8028 gfc_free_expr (e2vtab
);
8030 size_in_bytes
= size
;
8034 /* Otherwise use the length in bytes of the rhs. */
8035 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8036 size_in_bytes
= size
;
8039 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8040 size_in_bytes
, size_one_node
);
8042 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8044 tmp
= build_call_expr_loc (input_location
,
8045 builtin_decl_explicit (BUILT_IN_CALLOC
),
8046 2, build_one_cst (size_type_node
),
8048 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8049 gfc_add_modify (block
, comp
, tmp
);
8053 tmp
= build_call_expr_loc (input_location
,
8054 builtin_decl_explicit (BUILT_IN_MALLOC
),
8056 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8057 ptr
= gfc_class_data_get (comp
);
8060 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8061 gfc_add_modify (block
, ptr
, tmp
);
8064 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8065 /* Update the lhs character length. */
8066 gfc_add_modify (block
, lhs_cl_size
,
8067 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8071 /* Assign a single component of a derived type constructor. */
8074 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8075 gfc_symbol
*sym
, bool init
)
8083 gfc_start_block (&block
);
8085 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8087 /* Only care about pointers here, not about allocatables. */
8088 gfc_init_se (&se
, NULL
);
8089 /* Pointer component. */
8090 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8091 && !cm
->attr
.proc_pointer
)
8093 /* Array pointer. */
8094 if (expr
->expr_type
== EXPR_NULL
)
8095 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8098 se
.direct_byref
= 1;
8100 gfc_conv_expr_descriptor (&se
, expr
);
8101 gfc_add_block_to_block (&block
, &se
.pre
);
8102 gfc_add_block_to_block (&block
, &se
.post
);
8107 /* Scalar pointers. */
8108 se
.want_pointer
= 1;
8109 gfc_conv_expr (&se
, expr
);
8110 gfc_add_block_to_block (&block
, &se
.pre
);
8112 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8113 && expr
->symtree
->n
.sym
->attr
.dummy
)
8114 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8116 gfc_add_modify (&block
, dest
,
8117 fold_convert (TREE_TYPE (dest
), se
.expr
));
8118 gfc_add_block_to_block (&block
, &se
.post
);
8121 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8123 /* NULL initialization for CLASS components. */
8124 tmp
= gfc_trans_structure_assign (dest
,
8125 gfc_class_initializer (&cm
->ts
, expr
),
8127 gfc_add_expr_to_block (&block
, tmp
);
8129 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8130 && !cm
->attr
.proc_pointer
)
8132 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8133 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8134 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8136 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8137 gfc_add_expr_to_block (&block
, tmp
);
8141 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8142 gfc_add_expr_to_block (&block
, tmp
);
8145 else if (cm
->ts
.type
== BT_CLASS
8146 && CLASS_DATA (cm
)->attr
.dimension
8147 && CLASS_DATA (cm
)->attr
.allocatable
8148 && expr
->ts
.type
== BT_DERIVED
)
8150 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8151 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8152 tmp
= gfc_class_vptr_get (dest
);
8153 gfc_add_modify (&block
, tmp
,
8154 fold_convert (TREE_TYPE (tmp
), vtab
));
8155 tmp
= gfc_class_data_get (dest
);
8156 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8157 gfc_add_expr_to_block (&block
, tmp
);
8159 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8161 /* NULL initialization for allocatable components. */
8162 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8163 null_pointer_node
));
8165 else if (init
&& (cm
->attr
.allocatable
8166 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8167 && expr
->ts
.type
!= BT_CLASS
)))
8169 /* Take care about non-array allocatable components here. The alloc_*
8170 routine below is motivated by the alloc_scalar_allocatable_for_
8171 assignment() routine, but with the realloc portions removed and
8173 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8178 /* The remainder of these instructions follow the if (cm->attr.pointer)
8179 if (!cm->attr.dimension) part above. */
8180 gfc_init_se (&se
, NULL
);
8181 gfc_conv_expr (&se
, expr
);
8182 gfc_add_block_to_block (&block
, &se
.pre
);
8184 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8185 && expr
->symtree
->n
.sym
->attr
.dummy
)
8186 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8188 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8190 tmp
= gfc_class_data_get (dest
);
8191 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8192 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8193 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8194 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8195 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8198 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8200 /* For deferred strings insert a memcpy. */
8201 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8204 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8205 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8207 : expr
->ts
.u
.cl
->backend_decl
);
8208 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8209 gfc_add_expr_to_block (&block
, tmp
);
8212 gfc_add_modify (&block
, tmp
,
8213 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8214 gfc_add_block_to_block (&block
, &se
.post
);
8216 else if (expr
->ts
.type
== BT_UNION
)
8219 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8220 /* We mark that the entire union should be initialized with a contrived
8221 EXPR_NULL expression at the beginning. */
8222 if (c
!= NULL
&& c
->n
.component
== NULL
8223 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8225 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8226 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8227 gfc_add_expr_to_block (&block
, tmp
);
8228 c
= gfc_constructor_next (c
);
8230 /* The following constructor expression, if any, represents a specific
8231 map intializer, as given by the user. */
8232 if (c
!= NULL
&& c
->expr
!= NULL
)
8234 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8235 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8236 gfc_add_expr_to_block (&block
, tmp
);
8239 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8241 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8243 tree dealloc
= NULL_TREE
;
8244 gfc_init_se (&se
, NULL
);
8245 gfc_conv_expr (&se
, expr
);
8246 gfc_add_block_to_block (&block
, &se
.pre
);
8247 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8248 expression in a temporary variable and deallocate the allocatable
8249 components. Then we can the copy the expression to the result. */
8250 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8251 && expr
->expr_type
!= EXPR_VARIABLE
)
8253 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8254 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8257 gfc_add_modify (&block
, dest
,
8258 fold_convert (TREE_TYPE (dest
), se
.expr
));
8259 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8260 && expr
->expr_type
!= EXPR_NULL
)
8262 // TODO: Fix caf_mode
8263 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8264 dest
, expr
->rank
, 0);
8265 gfc_add_expr_to_block (&block
, tmp
);
8266 if (dealloc
!= NULL_TREE
)
8267 gfc_add_expr_to_block (&block
, dealloc
);
8269 gfc_add_block_to_block (&block
, &se
.post
);
8273 /* Nested constructors. */
8274 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8275 gfc_add_expr_to_block (&block
, tmp
);
8278 else if (gfc_deferred_strlen (cm
, &tmp
))
8282 gcc_assert (strlen
);
8283 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8285 TREE_OPERAND (dest
, 0),
8288 if (expr
->expr_type
== EXPR_NULL
)
8290 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
8291 gfc_add_modify (&block
, dest
, tmp
);
8292 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
8293 gfc_add_modify (&block
, strlen
, tmp
);
8298 gfc_init_se (&se
, NULL
);
8299 gfc_conv_expr (&se
, expr
);
8300 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
8301 tmp
= build_call_expr_loc (input_location
,
8302 builtin_decl_explicit (BUILT_IN_MALLOC
),
8304 gfc_add_modify (&block
, dest
,
8305 fold_convert (TREE_TYPE (dest
), tmp
));
8306 gfc_add_modify (&block
, strlen
,
8307 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
8308 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
8309 gfc_add_expr_to_block (&block
, tmp
);
8312 else if (!cm
->attr
.artificial
)
8314 /* Scalar component (excluding deferred parameters). */
8315 gfc_init_se (&se
, NULL
);
8316 gfc_init_se (&lse
, NULL
);
8318 gfc_conv_expr (&se
, expr
);
8319 if (cm
->ts
.type
== BT_CHARACTER
)
8320 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8322 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
8323 gfc_add_expr_to_block (&block
, tmp
);
8325 return gfc_finish_block (&block
);
8328 /* Assign a derived type constructor to a variable. */
8331 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
8340 gfc_start_block (&block
);
8342 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
8343 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
8344 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
8348 gfc_init_se (&se
, NULL
);
8349 gfc_init_se (&lse
, NULL
);
8350 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
8352 gfc_add_modify (&block
, lse
.expr
,
8353 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
8355 return gfc_finish_block (&block
);
8358 /* Make sure that the derived type has been completely built. */
8359 if (!expr
->ts
.u
.derived
->backend_decl
8360 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
8362 tmp
= gfc_typenode_for_spec (&expr
->ts
);
8366 cm
= expr
->ts
.u
.derived
->components
;
8370 gfc_init_se (&se
, NULL
);
8372 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8373 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8375 /* Skip absent members in default initializers. */
8376 if (!c
->expr
&& !cm
->attr
.allocatable
)
8379 /* Register the component with the caf-lib before it is initialized.
8380 Register only allocatable components, that are not coarray'ed
8381 components (%comp[*]). Only register when the constructor is not the
8383 if (coarray
&& !cm
->attr
.codimension
8384 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
8385 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
8387 tree token
, desc
, size
;
8388 bool is_array
= cm
->ts
.type
== BT_CLASS
8389 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
8391 field
= cm
->backend_decl
;
8392 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
8393 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
8394 if (cm
->ts
.type
== BT_CLASS
)
8395 field
= gfc_class_data_get (field
);
8397 token
= is_array
? gfc_conv_descriptor_token (field
)
8398 : fold_build3_loc (input_location
, COMPONENT_REF
,
8399 TREE_TYPE (cm
->caf_token
), dest
,
8400 cm
->caf_token
, NULL_TREE
);
8404 /* The _caf_register routine looks at the rank of the array
8405 descriptor to decide whether the data registered is an array
8407 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
8409 /* When the rank is not known just set a positive rank, which
8410 suffices to recognize the data as array. */
8413 size
= build_zero_cst (size_type_node
);
8415 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
8416 build_int_cst (signed_char_type_node
, rank
));
8420 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8421 cm
->ts
.type
== BT_CLASS
8422 ? CLASS_DATA (cm
)->attr
8424 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8426 gfc_add_block_to_block (&block
, &se
.pre
);
8427 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8428 7, size
, build_int_cst (
8430 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8431 gfc_build_addr_expr (pvoid_type_node
,
8433 gfc_build_addr_expr (NULL_TREE
, desc
),
8434 null_pointer_node
, null_pointer_node
,
8436 gfc_add_expr_to_block (&block
, tmp
);
8438 field
= cm
->backend_decl
;
8440 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8441 dest
, field
, NULL_TREE
);
8444 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8445 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8450 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8451 expr
->ts
.u
.derived
, init
);
8452 gfc_add_expr_to_block (&block
, tmp
);
8454 return gfc_finish_block (&block
);
8458 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8459 gfc_component
*un
, gfc_expr
*init
)
8461 gfc_constructor
*ctor
;
8463 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8466 ctor
= gfc_constructor_first (init
->value
.constructor
);
8468 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8471 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8473 /* If we have an 'initialize all' constructor, do it first. */
8474 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8476 tree union_type
= TREE_TYPE (un
->backend_decl
);
8477 tree val
= build_constructor (union_type
, NULL
);
8478 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8479 ctor
= gfc_constructor_next (ctor
);
8482 /* Add the map initializer on top. */
8483 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8485 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8486 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8487 TREE_TYPE (un
->backend_decl
),
8488 un
->attr
.dimension
, un
->attr
.pointer
,
8489 un
->attr
.proc_pointer
);
8490 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8494 /* Build an expression for a constructor. If init is nonzero then
8495 this is part of a static variable initializer. */
8498 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8505 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8507 gcc_assert (se
->ss
== NULL
);
8508 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8509 type
= gfc_typenode_for_spec (&expr
->ts
);
8513 /* Create a temporary variable and fill it in. */
8514 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8515 /* The symtree in expr is NULL, if the code to generate is for
8516 initializing the static members only. */
8517 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8519 gfc_add_expr_to_block (&se
->pre
, tmp
);
8523 cm
= expr
->ts
.u
.derived
->components
;
8525 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8526 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8528 /* Skip absent members in default initializers and allocatable
8529 components. Although the latter have a default initializer
8530 of EXPR_NULL,... by default, the static nullify is not needed
8531 since this is done every time we come into scope. */
8532 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8535 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8536 && strcmp (cm
->name
, "_extends") == 0
8537 && cm
->initializer
->symtree
)
8541 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8542 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8543 vtab
= unshare_expr_without_location (vtab
);
8544 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8546 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8548 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8549 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8550 fold_convert (TREE_TYPE (cm
->backend_decl
),
8553 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8554 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8555 fold_convert (TREE_TYPE (cm
->backend_decl
),
8556 integer_zero_node
));
8557 else if (cm
->ts
.type
== BT_UNION
)
8558 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8561 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8562 TREE_TYPE (cm
->backend_decl
),
8563 cm
->attr
.dimension
, cm
->attr
.pointer
,
8564 cm
->attr
.proc_pointer
);
8565 val
= unshare_expr_without_location (val
);
8567 /* Append it to the constructor list. */
8568 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8572 se
->expr
= build_constructor (type
, v
);
8574 TREE_CONSTANT (se
->expr
) = 1;
8578 /* Translate a substring expression. */
8581 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8587 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8589 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8590 expr
->value
.character
.length
,
8591 expr
->value
.character
.string
);
8593 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8594 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8597 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8601 /* Entry point for expression translation. Evaluates a scalar quantity.
8602 EXPR is the expression to be translated, and SE is the state structure if
8603 called from within the scalarized. */
8606 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8611 if (ss
&& ss
->info
->expr
== expr
8612 && (ss
->info
->type
== GFC_SS_SCALAR
8613 || ss
->info
->type
== GFC_SS_REFERENCE
))
8615 gfc_ss_info
*ss_info
;
8618 /* Substitute a scalar expression evaluated outside the scalarization
8620 se
->expr
= ss_info
->data
.scalar
.value
;
8621 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8622 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8624 se
->string_length
= ss_info
->string_length
;
8625 gfc_advance_se_ss_chain (se
);
8629 /* We need to convert the expressions for the iso_c_binding derived types.
8630 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8631 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8632 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8633 updated to be an integer with a kind equal to the size of a (void *). */
8634 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8635 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8637 if (expr
->expr_type
== EXPR_VARIABLE
8638 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8639 || expr
->symtree
->n
.sym
->intmod_sym_id
8640 == ISOCBINDING_NULL_FUNPTR
))
8642 /* Set expr_type to EXPR_NULL, which will result in
8643 null_pointer_node being used below. */
8644 expr
->expr_type
= EXPR_NULL
;
8648 /* Update the type/kind of the expression to be what the new
8649 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8650 expr
->ts
.type
= BT_INTEGER
;
8651 expr
->ts
.f90_type
= BT_VOID
;
8652 expr
->ts
.kind
= gfc_index_integer_kind
;
8656 gfc_fix_class_refs (expr
);
8658 switch (expr
->expr_type
)
8661 gfc_conv_expr_op (se
, expr
);
8665 gfc_conv_function_expr (se
, expr
);
8669 gfc_conv_constant (se
, expr
);
8673 gfc_conv_variable (se
, expr
);
8677 se
->expr
= null_pointer_node
;
8680 case EXPR_SUBSTRING
:
8681 gfc_conv_substring_expr (se
, expr
);
8684 case EXPR_STRUCTURE
:
8685 gfc_conv_structure (se
, expr
, 0);
8689 gfc_conv_array_constructor_expr (se
, expr
);
8698 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8699 of an assignment. */
8701 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8703 gfc_conv_expr (se
, expr
);
8704 /* All numeric lvalues should have empty post chains. If not we need to
8705 figure out a way of rewriting an lvalue so that it has no post chain. */
8706 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8709 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8710 numeric expressions. Used for scalar values where inserting cleanup code
8713 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8717 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8718 gfc_conv_expr (se
, expr
);
8721 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8722 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8724 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8728 /* Helper to translate an expression and convert it to a particular type. */
8730 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8732 gfc_conv_expr_val (se
, expr
);
8733 se
->expr
= convert (type
, se
->expr
);
8737 /* Converts an expression so that it can be passed by reference. Scalar
8741 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8747 if (ss
&& ss
->info
->expr
== expr
8748 && ss
->info
->type
== GFC_SS_REFERENCE
)
8750 /* Returns a reference to the scalar evaluated outside the loop
8752 gfc_conv_expr (se
, expr
);
8754 if (expr
->ts
.type
== BT_CHARACTER
8755 && expr
->expr_type
!= EXPR_FUNCTION
)
8756 gfc_conv_string_parameter (se
);
8758 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8763 if (expr
->ts
.type
== BT_CHARACTER
)
8765 gfc_conv_expr (se
, expr
);
8766 gfc_conv_string_parameter (se
);
8770 if (expr
->expr_type
== EXPR_VARIABLE
)
8772 se
->want_pointer
= 1;
8773 gfc_conv_expr (se
, expr
);
8776 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8777 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8778 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8781 else if (add_clobber
&& expr
->ref
== NULL
)
8785 /* FIXME: This fails if var is passed by reference, see PR
8787 var
= expr
->symtree
->n
.sym
->backend_decl
;
8788 clobber
= build_clobber (TREE_TYPE (var
));
8789 gfc_add_modify (&se
->pre
, var
, clobber
);
8794 if (expr
->expr_type
== EXPR_FUNCTION
8795 && ((expr
->value
.function
.esym
8796 && expr
->value
.function
.esym
->result
->attr
.pointer
8797 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8798 || (!expr
->value
.function
.esym
&& !expr
->ref
8799 && expr
->symtree
->n
.sym
->attr
.pointer
8800 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8802 se
->want_pointer
= 1;
8803 gfc_conv_expr (se
, expr
);
8804 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8805 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8810 gfc_conv_expr (se
, expr
);
8812 /* Create a temporary var to hold the value. */
8813 if (TREE_CONSTANT (se
->expr
))
8815 tree tmp
= se
->expr
;
8816 STRIP_TYPE_NOPS (tmp
);
8817 var
= build_decl (input_location
,
8818 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8819 DECL_INITIAL (var
) = tmp
;
8820 TREE_STATIC (var
) = 1;
8825 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8826 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8829 if (!expr
->must_finalize
)
8830 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8832 /* Take the address of that value. */
8833 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8837 /* Get the _len component for an unlimited polymorphic expression. */
8840 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8843 gfc_ref
*ref
= expr
->ref
;
8845 gfc_init_se (&se
, NULL
);
8846 while (ref
&& ref
->next
)
8848 gfc_add_len_component (expr
);
8849 gfc_conv_expr (&se
, expr
);
8850 gfc_add_block_to_block (block
, &se
.pre
);
8851 gcc_assert (se
.post
.head
== NULL_TREE
);
8854 gfc_free_ref_list (ref
->next
);
8859 gfc_free_ref_list (expr
->ref
);
8866 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8867 statement-list outside of the scalarizer-loop. When code is generated, that
8868 depends on the scalarized expression, it is added to RSE.PRE.
8869 Returns le's _vptr tree and when set the len expressions in to_lenp and
8870 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8874 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8875 gfc_expr
* re
, gfc_se
*rse
,
8876 tree
* to_lenp
, tree
* from_lenp
)
8879 gfc_expr
* vptr_expr
;
8880 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8881 bool set_vptr
= false, temp_rhs
= false;
8882 stmtblock_t
*pre
= block
;
8884 /* Create a temporary for complicated expressions. */
8885 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8886 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8888 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8890 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8895 /* Get the _vptr for the left-hand side expression. */
8896 gfc_init_se (&se
, NULL
);
8897 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8898 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8900 /* Care about _len for unlimited polymorphic entities. */
8901 if (UNLIMITED_POLY (vptr_expr
)
8902 || (vptr_expr
->ts
.type
== BT_DERIVED
8903 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8904 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8905 gfc_add_vptr_component (vptr_expr
);
8909 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8910 se
.want_pointer
= 1;
8911 gfc_conv_expr (&se
, vptr_expr
);
8912 gfc_free_expr (vptr_expr
);
8913 gfc_add_block_to_block (block
, &se
.pre
);
8914 gcc_assert (se
.post
.head
== NULL_TREE
);
8916 STRIP_NOPS (lhs_vptr
);
8918 /* Set the _vptr only when the left-hand side of the assignment is a
8922 /* Get the vptr from the rhs expression only, when it is variable.
8923 Functions are expected to be assigned to a temporary beforehand. */
8924 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8925 ? gfc_find_and_cut_at_last_class_ref (re
)
8927 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8929 if (to_len
!= NULL_TREE
)
8931 /* Get the _len information from the rhs. */
8932 if (UNLIMITED_POLY (vptr_expr
)
8933 || (vptr_expr
->ts
.type
== BT_DERIVED
8934 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8935 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8937 gfc_add_vptr_component (vptr_expr
);
8941 if (re
->expr_type
== EXPR_VARIABLE
8942 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8943 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8944 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8945 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8946 re
->symtree
->n
.sym
->backend_decl
))))
8949 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8950 re
->symtree
->n
.sym
->backend_decl
));
8952 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8953 re
->symtree
->n
.sym
->backend_decl
));
8955 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8958 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8959 if (UNLIMITED_POLY (re
))
8960 from_len
= gfc_class_len_get (rse
->expr
);
8962 else if (re
->expr_type
!= EXPR_NULL
)
8963 /* Only when rhs is non-NULL use its declared type for vptr
8965 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8967 /* When the rhs is NULL use the vtab of lhs' declared type. */
8968 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8973 gfc_init_se (&se
, NULL
);
8974 se
.want_pointer
= 1;
8975 gfc_conv_expr (&se
, vptr_expr
);
8976 gfc_free_expr (vptr_expr
);
8977 gfc_add_block_to_block (block
, &se
.pre
);
8978 gcc_assert (se
.post
.head
== NULL_TREE
);
8980 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8983 if (to_len
!= NULL_TREE
)
8985 /* The _len component needs to be set. Figure how to get the
8986 value of the right-hand side. */
8987 if (from_len
== NULL_TREE
)
8989 if (rse
->string_length
!= NULL_TREE
)
8990 from_len
= rse
->string_length
;
8991 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8993 gfc_init_se (&se
, NULL
);
8994 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8995 gfc_add_block_to_block (block
, &se
.pre
);
8996 gcc_assert (se
.post
.head
== NULL_TREE
);
8997 from_len
= gfc_evaluate_now (se
.expr
, block
);
9000 from_len
= build_zero_cst (gfc_charlen_type_node
);
9002 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9007 /* Return the _len trees only, when requested. */
9011 *from_lenp
= from_len
;
9016 /* Assign tokens for pointer components. */
9019 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9022 symbol_attribute lhs_attr
, rhs_attr
;
9023 tree tmp
, lhs_tok
, rhs_tok
;
9024 /* Flag to indicated component refs on the rhs. */
9027 lhs_attr
= gfc_caf_attr (expr1
);
9028 if (expr2
->expr_type
!= EXPR_NULL
)
9030 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9031 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9033 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9034 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9037 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9041 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9042 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9045 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9047 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9048 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9051 else if (lhs_attr
.codimension
)
9053 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9054 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9055 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9056 lhs_tok
, null_pointer_node
);
9057 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9062 /* Do everything that is needed for a CLASS function expr2. */
9065 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9066 gfc_expr
*expr1
, gfc_expr
*expr2
)
9068 tree expr1_vptr
= NULL_TREE
;
9071 gfc_conv_function_expr (rse
, expr2
);
9072 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9074 if (expr1
->ts
.type
!= BT_CLASS
)
9075 rse
->expr
= gfc_class_data_get (rse
->expr
);
9078 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9081 gfc_add_block_to_block (block
, &rse
->pre
);
9082 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9083 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9085 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9086 fold_convert (TREE_TYPE (expr1_vptr
),
9087 gfc_class_vptr_get (tmp
)));
9088 rse
->expr
= gfc_class_data_get (tmp
);
9096 gfc_trans_pointer_assign (gfc_code
* code
)
9098 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9102 /* Generate code for a pointer assignment. */
9105 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9112 tree expr1_vptr
= NULL_TREE
;
9113 bool scalar
, non_proc_ptr_assign
;
9116 gfc_start_block (&block
);
9118 gfc_init_se (&lse
, NULL
);
9120 /* Usually testing whether this is not a proc pointer assignment. */
9121 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9122 && expr2
->expr_type
== EXPR_VARIABLE
9123 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9125 /* Check whether the expression is a scalar or not; we cannot use
9126 expr1->rank as it can be nonzero for proc pointers. */
9127 ss
= gfc_walk_expr (expr1
);
9128 scalar
= ss
== gfc_ss_terminator
;
9130 gfc_free_ss_chain (ss
);
9132 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9133 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9135 gfc_add_data_component (expr2
);
9136 /* The following is required as gfc_add_data_component doesn't
9137 update ts.type if there is a tailing REF_ARRAY. */
9138 expr2
->ts
.type
= BT_DERIVED
;
9143 /* Scalar pointers. */
9144 lse
.want_pointer
= 1;
9145 gfc_conv_expr (&lse
, expr1
);
9146 gfc_init_se (&rse
, NULL
);
9147 rse
.want_pointer
= 1;
9148 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9149 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9151 gfc_conv_expr (&rse
, expr2
);
9153 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9155 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9157 lse
.expr
= gfc_class_data_get (lse
.expr
);
9160 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9161 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9162 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9165 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9166 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9167 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9170 gfc_add_block_to_block (&block
, &lse
.pre
);
9171 gfc_add_block_to_block (&block
, &rse
.pre
);
9173 /* Check character lengths if character expression. The test is only
9174 really added if -fbounds-check is enabled. Exclude deferred
9175 character length lefthand sides. */
9176 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9177 && !expr1
->ts
.deferred
9178 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9179 && !gfc_is_proc_ptr_comp (expr1
))
9181 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9182 gcc_assert (lse
.string_length
&& rse
.string_length
);
9183 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9184 lse
.string_length
, rse
.string_length
,
9188 /* The assignment to an deferred character length sets the string
9189 length to that of the rhs. */
9190 if (expr1
->ts
.deferred
)
9192 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9193 gfc_add_modify (&block
, lse
.string_length
,
9194 fold_convert (TREE_TYPE (lse
.string_length
),
9195 rse
.string_length
));
9196 else if (lse
.string_length
!= NULL
)
9197 gfc_add_modify (&block
, lse
.string_length
,
9198 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9201 gfc_add_modify (&block
, lse
.expr
,
9202 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9204 /* Also set the tokens for pointer components in derived typed
9206 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9207 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9209 gfc_add_block_to_block (&block
, &rse
.post
);
9210 gfc_add_block_to_block (&block
, &lse
.post
);
9217 tree strlen_rhs
= NULL_TREE
;
9219 /* Array pointer. Find the last reference on the LHS and if it is an
9220 array section ref, we're dealing with bounds remapping. In this case,
9221 set it to AR_FULL so that gfc_conv_expr_descriptor does
9222 not see it and process the bounds remapping afterwards explicitly. */
9223 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9224 if (!remap
->next
&& remap
->type
== REF_ARRAY
9225 && remap
->u
.ar
.type
== AR_SECTION
)
9227 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9229 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
9231 gfc_error ("If bounds remapping is specified at %L, "
9232 "the pointer target shall not be NULL", &expr1
->where
);
9236 gfc_init_se (&lse
, NULL
);
9238 lse
.descriptor_only
= 1;
9239 gfc_conv_expr_descriptor (&lse
, expr1
);
9240 strlen_lhs
= lse
.string_length
;
9243 if (expr2
->expr_type
== EXPR_NULL
)
9245 /* Just set the data pointer to null. */
9246 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9248 else if (rank_remap
)
9250 /* If we are rank-remapping, just get the RHS's descriptor and
9251 process this later on. */
9252 gfc_init_se (&rse
, NULL
);
9253 rse
.direct_byref
= 1;
9254 rse
.byref_noassign
= 1;
9256 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9257 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
9259 else if (expr2
->expr_type
== EXPR_FUNCTION
)
9261 tree bound
[GFC_MAX_DIMENSIONS
];
9264 for (i
= 0; i
< expr2
->rank
; i
++)
9265 bound
[i
] = NULL_TREE
;
9266 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
9267 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
9269 GFC_ARRAY_POINTER_CONT
, false);
9270 tmp
= gfc_create_var (tmp
, "ptrtemp");
9271 rse
.descriptor_only
= 0;
9273 rse
.direct_byref
= 1;
9274 gfc_conv_expr_descriptor (&rse
, expr2
);
9275 strlen_rhs
= rse
.string_length
;
9280 gfc_conv_expr_descriptor (&rse
, expr2
);
9281 strlen_rhs
= rse
.string_length
;
9282 if (expr1
->ts
.type
== BT_CLASS
)
9283 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9288 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9290 /* Assign directly to the LHS's descriptor. */
9291 lse
.descriptor_only
= 0;
9292 lse
.direct_byref
= 1;
9293 gfc_conv_expr_descriptor (&lse
, expr2
);
9294 strlen_rhs
= lse
.string_length
;
9296 if (expr1
->ts
.type
== BT_CLASS
)
9298 rse
.expr
= NULL_TREE
;
9299 rse
.string_length
= NULL_TREE
;
9300 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
9306 /* If the target is not a whole array, use the target array
9307 reference for remap. */
9308 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
9309 if (remap
->type
== REF_ARRAY
9310 && remap
->u
.ar
.type
== AR_FULL
9315 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9317 gfc_init_se (&rse
, NULL
);
9318 rse
.want_pointer
= 1;
9319 gfc_conv_function_expr (&rse
, expr2
);
9320 if (expr1
->ts
.type
!= BT_CLASS
)
9322 rse
.expr
= gfc_class_data_get (rse
.expr
);
9323 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9324 /* Set the lhs span. */
9325 tmp
= TREE_TYPE (rse
.expr
);
9326 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9327 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9328 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
9332 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9335 gfc_add_block_to_block (&block
, &rse
.pre
);
9336 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
9337 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
9339 gfc_add_modify (&lse
.pre
, expr1_vptr
,
9340 fold_convert (TREE_TYPE (expr1_vptr
),
9341 gfc_class_vptr_get (tmp
)));
9342 rse
.expr
= gfc_class_data_get (tmp
);
9343 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9348 /* Assign to a temporary descriptor and then copy that
9349 temporary to the pointer. */
9350 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
9351 lse
.descriptor_only
= 0;
9353 lse
.direct_byref
= 1;
9354 gfc_conv_expr_descriptor (&lse
, expr2
);
9355 strlen_rhs
= lse
.string_length
;
9356 gfc_add_modify (&lse
.pre
, desc
, tmp
);
9359 gfc_add_block_to_block (&block
, &lse
.pre
);
9361 gfc_add_block_to_block (&block
, &rse
.pre
);
9363 /* If we do bounds remapping, update LHS descriptor accordingly. */
9367 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
9371 /* Do rank remapping. We already have the RHS's descriptor
9372 converted in rse and now have to build the correct LHS
9373 descriptor for it. */
9375 tree dtype
, data
, span
;
9377 tree lbound
, ubound
;
9380 dtype
= gfc_conv_descriptor_dtype (desc
);
9381 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
9382 gfc_add_modify (&block
, dtype
, tmp
);
9384 /* Copy data pointer. */
9385 data
= gfc_conv_descriptor_data_get (rse
.expr
);
9386 gfc_conv_descriptor_data_set (&block
, desc
, data
);
9388 /* Copy the span. */
9389 if (TREE_CODE (rse
.expr
) == VAR_DECL
9390 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
9391 span
= gfc_conv_descriptor_span_get (rse
.expr
);
9394 tmp
= TREE_TYPE (rse
.expr
);
9395 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9396 span
= fold_convert (gfc_array_index_type
, tmp
);
9398 gfc_conv_descriptor_span_set (&block
, desc
, span
);
9400 /* Copy offset but adjust it such that it would correspond
9401 to a lbound of zero. */
9402 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
9403 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
9405 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9407 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
9409 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9410 gfc_array_index_type
, stride
, lbound
);
9411 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9412 gfc_array_index_type
, offs
, tmp
);
9414 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9416 /* Set the bounds as declared for the LHS and calculate strides as
9417 well as another offset update accordingly. */
9418 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9420 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9425 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9427 /* Convert declared bounds. */
9428 gfc_init_se (&lower_se
, NULL
);
9429 gfc_init_se (&upper_se
, NULL
);
9430 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9431 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9433 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9434 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9436 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9437 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9439 lbound
= gfc_evaluate_now (lbound
, &block
);
9440 ubound
= gfc_evaluate_now (ubound
, &block
);
9442 gfc_add_block_to_block (&block
, &lower_se
.post
);
9443 gfc_add_block_to_block (&block
, &upper_se
.post
);
9445 /* Set bounds in descriptor. */
9446 gfc_conv_descriptor_lbound_set (&block
, desc
,
9447 gfc_rank_cst
[dim
], lbound
);
9448 gfc_conv_descriptor_ubound_set (&block
, desc
,
9449 gfc_rank_cst
[dim
], ubound
);
9452 stride
= gfc_evaluate_now (stride
, &block
);
9453 gfc_conv_descriptor_stride_set (&block
, desc
,
9454 gfc_rank_cst
[dim
], stride
);
9456 /* Update offset. */
9457 offs
= gfc_conv_descriptor_offset_get (desc
);
9458 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9459 gfc_array_index_type
, lbound
, stride
);
9460 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9461 gfc_array_index_type
, offs
, tmp
);
9462 offs
= gfc_evaluate_now (offs
, &block
);
9463 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9465 /* Update stride. */
9466 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9467 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9468 gfc_array_index_type
, stride
, tmp
);
9473 /* Bounds remapping. Just shift the lower bounds. */
9475 gcc_assert (expr1
->rank
== expr2
->rank
);
9477 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9481 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9482 gfc_init_se (&lbound_se
, NULL
);
9483 if (remap
->u
.ar
.start
[dim
])
9485 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9486 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9489 /* This remap arises from a target that is not a whole
9490 array. The start expressions will be NULL but we need
9491 the lbounds to be one. */
9492 lbound_se
.expr
= gfc_index_one_node
;
9493 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9494 dim
, lbound_se
.expr
);
9495 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9500 /* If rank remapping was done, check with -fcheck=bounds that
9501 the target is at least as large as the pointer. */
9502 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9508 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9509 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9511 lsize
= gfc_evaluate_now (lsize
, &block
);
9512 rsize
= gfc_evaluate_now (rsize
, &block
);
9513 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9516 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9517 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9521 if (expr1
->ts
.type
== BT_CHARACTER
9522 && expr1
->symtree
->n
.sym
->ts
.deferred
9523 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9524 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9526 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9527 if (expr2
->expr_type
!= EXPR_NULL
)
9528 gfc_add_modify (&block
, tmp
,
9529 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9531 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9534 /* Check string lengths if applicable. The check is only really added
9535 to the output code if -fbounds-check is enabled. */
9536 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9538 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9539 gcc_assert (strlen_lhs
&& strlen_rhs
);
9540 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9541 strlen_lhs
, strlen_rhs
, &block
);
9544 gfc_add_block_to_block (&block
, &lse
.post
);
9546 gfc_add_block_to_block (&block
, &rse
.post
);
9549 return gfc_finish_block (&block
);
9553 /* Makes sure se is suitable for passing as a function string parameter. */
9554 /* TODO: Need to check all callers of this function. It may be abused. */
9557 gfc_conv_string_parameter (gfc_se
* se
)
9561 if (TREE_CODE (se
->expr
) == STRING_CST
)
9563 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9564 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9568 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
9569 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
9570 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9572 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9574 type
= TREE_TYPE (se
->expr
);
9575 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9579 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9581 type
= build_pointer_type (type
);
9582 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9586 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9590 /* Generate code for assignment of scalar variables. Includes character
9591 strings and derived types with allocatable components.
9592 If you know that the LHS has no allocations, set dealloc to false.
9594 DEEP_COPY has no effect if the typespec TS is not a derived type with
9595 allocatable components. Otherwise, if it is set, an explicit copy of each
9596 allocatable component is made. This is necessary as a simple copy of the
9597 whole object would copy array descriptors as is, so that the lhs's
9598 allocatable components would point to the rhs's after the assignment.
9599 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9600 necessary if the rhs is a non-pointer function, as the allocatable components
9601 are not accessible by other means than the function's result after the
9602 function has returned. It is even more subtle when temporaries are involved,
9603 as the two following examples show:
9604 1. When we evaluate an array constructor, a temporary is created. Thus
9605 there is theoretically no alias possible. However, no deep copy is
9606 made for this temporary, so that if the constructor is made of one or
9607 more variable with allocatable components, those components still point
9608 to the variable's: DEEP_COPY should be set for the assignment from the
9609 temporary to the lhs in that case.
9610 2. When assigning a scalar to an array, we evaluate the scalar value out
9611 of the loop, store it into a temporary variable, and assign from that.
9612 In that case, deep copying when assigning to the temporary would be a
9613 waste of resources; however deep copies should happen when assigning from
9614 the temporary to each array element: again DEEP_COPY should be set for
9615 the assignment from the temporary to the lhs. */
9618 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9619 bool deep_copy
, bool dealloc
, bool in_coarray
)
9625 gfc_init_block (&block
);
9627 if (ts
.type
== BT_CHARACTER
)
9632 if (lse
->string_length
!= NULL_TREE
)
9634 gfc_conv_string_parameter (lse
);
9635 gfc_add_block_to_block (&block
, &lse
->pre
);
9636 llen
= lse
->string_length
;
9639 if (rse
->string_length
!= NULL_TREE
)
9641 gfc_conv_string_parameter (rse
);
9642 gfc_add_block_to_block (&block
, &rse
->pre
);
9643 rlen
= rse
->string_length
;
9646 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9647 rse
->expr
, ts
.kind
);
9649 else if (gfc_bt_struct (ts
.type
)
9650 && (ts
.u
.derived
->attr
.alloc_comp
9651 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9653 tree tmp_var
= NULL_TREE
;
9656 /* Are the rhs and the lhs the same? */
9659 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9660 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9661 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9662 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9665 /* Deallocate the lhs allocated components as long as it is not
9666 the same as the rhs. This must be done following the assignment
9667 to prevent deallocating data that could be used in the rhs
9671 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9672 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9674 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9676 gfc_add_expr_to_block (&lse
->post
, tmp
);
9679 gfc_add_block_to_block (&block
, &rse
->pre
);
9680 gfc_add_block_to_block (&block
, &lse
->pre
);
9682 gfc_add_modify (&block
, lse
->expr
,
9683 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9685 /* Restore pointer address of coarray components. */
9686 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9688 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9689 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9691 gfc_add_expr_to_block (&block
, tmp
);
9694 /* Do a deep copy if the rhs is a variable, if it is not the
9698 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9699 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9700 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9702 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9704 gfc_add_expr_to_block (&block
, tmp
);
9707 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
9709 gfc_add_block_to_block (&block
, &lse
->pre
);
9710 gfc_add_block_to_block (&block
, &rse
->pre
);
9711 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9712 TREE_TYPE (lse
->expr
), rse
->expr
);
9713 gfc_add_modify (&block
, lse
->expr
, tmp
);
9717 gfc_add_block_to_block (&block
, &lse
->pre
);
9718 gfc_add_block_to_block (&block
, &rse
->pre
);
9720 gfc_add_modify (&block
, lse
->expr
,
9721 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9724 gfc_add_block_to_block (&block
, &lse
->post
);
9725 gfc_add_block_to_block (&block
, &rse
->post
);
9727 return gfc_finish_block (&block
);
9731 /* There are quite a lot of restrictions on the optimisation in using an
9732 array function assign without a temporary. */
9735 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9738 bool seen_array_ref
;
9740 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9742 /* Play it safe with class functions assigned to a derived type. */
9743 if (gfc_is_class_array_function (expr2
)
9744 && expr1
->ts
.type
== BT_DERIVED
)
9747 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9748 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9751 /* Elemental functions are scalarized so that they don't need a
9752 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9753 they would need special treatment in gfc_trans_arrayfunc_assign. */
9754 if (expr2
->value
.function
.esym
!= NULL
9755 && expr2
->value
.function
.esym
->attr
.elemental
)
9758 /* Need a temporary if rhs is not FULL or a contiguous section. */
9759 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9762 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9763 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9766 /* Functions returning pointers or allocatables need temporaries. */
9767 c
= expr2
->value
.function
.esym
9768 ? (expr2
->value
.function
.esym
->attr
.pointer
9769 || expr2
->value
.function
.esym
->attr
.allocatable
)
9770 : (expr2
->symtree
->n
.sym
->attr
.pointer
9771 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9775 /* Character array functions need temporaries unless the
9776 character lengths are the same. */
9777 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9779 if (expr1
->ts
.u
.cl
->length
== NULL
9780 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9783 if (expr2
->ts
.u
.cl
->length
== NULL
9784 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9787 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9788 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9792 /* Check that no LHS component references appear during an array
9793 reference. This is needed because we do not have the means to
9794 span any arbitrary stride with an array descriptor. This check
9795 is not needed for the rhs because the function result has to be
9797 seen_array_ref
= false;
9798 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9800 if (ref
->type
== REF_ARRAY
)
9801 seen_array_ref
= true;
9802 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9806 /* Check for a dependency. */
9807 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9808 expr2
->value
.function
.esym
,
9809 expr2
->value
.function
.actual
,
9813 /* If we have reached here with an intrinsic function, we do not
9814 need a temporary except in the particular case that reallocation
9815 on assignment is active and the lhs is allocatable and a target. */
9816 if (expr2
->value
.function
.isym
)
9817 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9819 /* If the LHS is a dummy, we need a temporary if it is not
9821 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9824 /* If the lhs has been host_associated, is in common, a pointer or is
9825 a target and the function is not using a RESULT variable, aliasing
9826 can occur and a temporary is needed. */
9827 if ((sym
->attr
.host_assoc
9828 || sym
->attr
.in_common
9829 || sym
->attr
.pointer
9830 || sym
->attr
.cray_pointee
9831 || sym
->attr
.target
)
9832 && expr2
->symtree
!= NULL
9833 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9836 /* A PURE function can unconditionally be called without a temporary. */
9837 if (expr2
->value
.function
.esym
!= NULL
9838 && expr2
->value
.function
.esym
->attr
.pure
)
9841 /* Implicit_pure functions are those which could legally be declared
9843 if (expr2
->value
.function
.esym
!= NULL
9844 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9847 if (!sym
->attr
.use_assoc
9848 && !sym
->attr
.in_common
9849 && !sym
->attr
.pointer
9850 && !sym
->attr
.target
9851 && !sym
->attr
.cray_pointee
9852 && expr2
->value
.function
.esym
)
9854 /* A temporary is not needed if the function is not contained and
9855 the variable is local or host associated and not a pointer or
9857 if (!expr2
->value
.function
.esym
->attr
.contained
)
9860 /* A temporary is not needed if the lhs has never been host
9861 associated and the procedure is contained. */
9862 else if (!sym
->attr
.host_assoc
)
9865 /* A temporary is not needed if the variable is local and not
9866 a pointer, a target or a result. */
9868 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9872 /* Default to temporary use. */
9877 /* Provide the loop info so that the lhs descriptor can be built for
9878 reallocatable assignments from extrinsic function calls. */
9881 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9884 /* Signal that the function call should not be made by
9885 gfc_conv_loop_setup. */
9886 se
->ss
->is_alloc_lhs
= 1;
9887 gfc_init_loopinfo (loop
);
9888 gfc_add_ss_to_loop (loop
, *ss
);
9889 gfc_add_ss_to_loop (loop
, se
->ss
);
9890 gfc_conv_ss_startstride (loop
);
9891 gfc_conv_loop_setup (loop
, where
);
9892 gfc_copy_loopinfo_to_se (se
, loop
);
9893 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9894 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9895 se
->ss
->is_alloc_lhs
= 0;
9899 /* For assignment to a reallocatable lhs from intrinsic functions,
9900 replace the se.expr (ie. the result) with a temporary descriptor.
9901 Null the data field so that the library allocates space for the
9902 result. Free the data of the original descriptor after the function,
9903 in case it appears in an argument expression and transfer the
9904 result to the original descriptor. */
9907 fcncall_realloc_result (gfc_se
*se
, int rank
)
9916 /* Use the allocation done by the library. Substitute the lhs
9917 descriptor with a copy, whose data field is nulled.*/
9918 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9919 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9920 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9922 /* Unallocated, the descriptor does not have a dtype. */
9923 tmp
= gfc_conv_descriptor_dtype (desc
);
9924 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9926 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9927 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9928 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9930 /* Free the lhs after the function call and copy the result data to
9931 the lhs descriptor. */
9932 tmp
= gfc_conv_descriptor_data_get (desc
);
9933 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9934 logical_type_node
, tmp
,
9935 build_int_cst (TREE_TYPE (tmp
), 0));
9936 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9937 tmp
= gfc_call_free (tmp
);
9938 gfc_add_expr_to_block (&se
->post
, tmp
);
9940 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9941 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9943 /* Check that the shapes are the same between lhs and expression. */
9944 for (n
= 0 ; n
< rank
; n
++)
9947 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9948 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9949 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9950 gfc_array_index_type
, tmp
, tmp1
);
9951 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9952 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9953 gfc_array_index_type
, tmp
, tmp1
);
9954 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9955 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9956 gfc_array_index_type
, tmp
, tmp1
);
9957 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9958 logical_type_node
, tmp
,
9959 gfc_index_zero_node
);
9960 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9961 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9962 logical_type_node
, tmp
,
9966 /* 'zero_cond' being true is equal to lhs not being allocated or the
9967 shapes being different. */
9968 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9970 /* Now reset the bounds returned from the function call to bounds based
9971 on the lhs lbounds, except where the lhs is not allocated or the shapes
9972 of 'variable and 'expr' are different. Set the offset accordingly. */
9973 offset
= gfc_index_zero_node
;
9974 for (n
= 0 ; n
< rank
; n
++)
9978 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9979 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9980 gfc_array_index_type
, zero_cond
,
9981 gfc_index_one_node
, lbound
);
9982 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9984 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9985 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9986 gfc_array_index_type
, tmp
, lbound
);
9987 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9988 gfc_rank_cst
[n
], lbound
);
9989 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9990 gfc_rank_cst
[n
], tmp
);
9992 /* Set stride and accumulate the offset. */
9993 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9994 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9995 gfc_rank_cst
[n
], tmp
);
9996 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9997 gfc_array_index_type
, lbound
, tmp
);
9998 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9999 gfc_array_index_type
, offset
, tmp
);
10000 offset
= gfc_evaluate_now (offset
, &se
->post
);
10003 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10008 /* Try to translate array(:) = func (...), where func is a transformational
10009 array function, without using a temporary. Returns NULL if this isn't the
10013 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10017 gfc_component
*comp
= NULL
;
10020 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10023 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10025 comp
= gfc_get_proc_ptr_comp (expr2
);
10027 if (!(expr2
->value
.function
.isym
10028 || (comp
&& comp
->attr
.dimension
)
10029 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10030 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10033 gfc_init_se (&se
, NULL
);
10034 gfc_start_block (&se
.pre
);
10035 se
.want_pointer
= 1;
10037 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10039 if (expr1
->ts
.type
== BT_DERIVED
10040 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10043 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10045 gfc_add_expr_to_block (&se
.pre
, tmp
);
10048 se
.direct_byref
= 1;
10049 se
.ss
= gfc_walk_expr (expr2
);
10050 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10052 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10053 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10054 Clearly, this cannot be done for an allocatable function result, since
10055 the shape of the result is unknown and, in any case, the function must
10056 correctly take care of the reallocation internally. For intrinsic
10057 calls, the array data is freed and the library takes care of allocation.
10058 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10060 if (flag_realloc_lhs
10061 && gfc_is_reallocatable_lhs (expr1
)
10062 && !gfc_expr_attr (expr1
).codimension
10063 && !gfc_is_coindexed (expr1
)
10064 && !(expr2
->value
.function
.esym
10065 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10067 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10069 if (!expr2
->value
.function
.isym
)
10071 ss
= gfc_walk_expr (expr1
);
10072 gcc_assert (ss
!= gfc_ss_terminator
);
10074 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10075 ss
->is_alloc_lhs
= 1;
10078 fcncall_realloc_result (&se
, expr1
->rank
);
10081 gfc_conv_function_expr (&se
, expr2
);
10082 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10085 gfc_cleanup_loop (&loop
);
10087 gfc_free_ss_chain (se
.ss
);
10089 return gfc_finish_block (&se
.pre
);
10093 /* Try to efficiently translate array(:) = 0. Return NULL if this
10097 gfc_trans_zero_assign (gfc_expr
* expr
)
10099 tree dest
, len
, type
;
10103 sym
= expr
->symtree
->n
.sym
;
10104 dest
= gfc_get_symbol_decl (sym
);
10106 type
= TREE_TYPE (dest
);
10107 if (POINTER_TYPE_P (type
))
10108 type
= TREE_TYPE (type
);
10109 if (!GFC_ARRAY_TYPE_P (type
))
10112 /* Determine the length of the array. */
10113 len
= GFC_TYPE_ARRAY_SIZE (type
);
10114 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10117 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10118 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10119 fold_convert (gfc_array_index_type
, tmp
));
10121 /* If we are zeroing a local array avoid taking its address by emitting
10123 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10124 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10125 dest
, build_constructor (TREE_TYPE (dest
),
10128 /* Convert arguments to the correct types. */
10129 dest
= fold_convert (pvoid_type_node
, dest
);
10130 len
= fold_convert (size_type_node
, len
);
10132 /* Construct call to __builtin_memset. */
10133 tmp
= build_call_expr_loc (input_location
,
10134 builtin_decl_explicit (BUILT_IN_MEMSET
),
10135 3, dest
, integer_zero_node
, len
);
10136 return fold_convert (void_type_node
, tmp
);
10140 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10141 that constructs the call to __builtin_memcpy. */
10144 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10148 /* Convert arguments to the correct types. */
10149 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10150 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10152 dst
= fold_convert (pvoid_type_node
, dst
);
10154 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10155 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10157 src
= fold_convert (pvoid_type_node
, src
);
10159 len
= fold_convert (size_type_node
, len
);
10161 /* Construct call to __builtin_memcpy. */
10162 tmp
= build_call_expr_loc (input_location
,
10163 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10165 return fold_convert (void_type_node
, tmp
);
10169 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10170 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10171 source/rhs, both are gfc_full_array_ref_p which have been checked for
10175 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10177 tree dst
, dlen
, dtype
;
10178 tree src
, slen
, stype
;
10181 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10182 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10184 dtype
= TREE_TYPE (dst
);
10185 if (POINTER_TYPE_P (dtype
))
10186 dtype
= TREE_TYPE (dtype
);
10187 stype
= TREE_TYPE (src
);
10188 if (POINTER_TYPE_P (stype
))
10189 stype
= TREE_TYPE (stype
);
10191 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10194 /* Determine the lengths of the arrays. */
10195 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10196 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10198 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10199 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10200 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10202 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10203 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10205 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10206 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10207 slen
, fold_convert (gfc_array_index_type
, tmp
));
10209 /* Sanity check that they are the same. This should always be
10210 the case, as we should already have checked for conformance. */
10211 if (!tree_int_cst_equal (slen
, dlen
))
10214 return gfc_build_memcpy_call (dst
, src
, dlen
);
10218 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10219 this can't be done. EXPR1 is the destination/lhs for which
10220 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10223 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10225 unsigned HOST_WIDE_INT nelem
;
10231 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
10235 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10236 dtype
= TREE_TYPE (dst
);
10237 if (POINTER_TYPE_P (dtype
))
10238 dtype
= TREE_TYPE (dtype
);
10239 if (!GFC_ARRAY_TYPE_P (dtype
))
10242 /* Determine the lengths of the array. */
10243 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
10244 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10247 /* Confirm that the constructor is the same size. */
10248 if (compare_tree_int (len
, nelem
) != 0)
10251 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10252 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10253 fold_convert (gfc_array_index_type
, tmp
));
10255 stype
= gfc_typenode_for_spec (&expr2
->ts
);
10256 src
= gfc_build_constant_array_constructor (expr2
, stype
);
10258 return gfc_build_memcpy_call (dst
, src
, len
);
10262 /* Tells whether the expression is to be treated as a variable reference. */
10265 gfc_expr_is_variable (gfc_expr
*expr
)
10268 gfc_component
*comp
;
10269 gfc_symbol
*func_ifc
;
10271 if (expr
->expr_type
== EXPR_VARIABLE
)
10274 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
10277 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
10278 return gfc_expr_is_variable (arg
);
10281 /* A data-pointer-returning function should be considered as a variable
10283 if (expr
->expr_type
== EXPR_FUNCTION
10284 && expr
->ref
== NULL
)
10286 if (expr
->value
.function
.isym
!= NULL
)
10289 if (expr
->value
.function
.esym
!= NULL
)
10291 func_ifc
= expr
->value
.function
.esym
;
10296 gcc_assert (expr
->symtree
);
10297 func_ifc
= expr
->symtree
->n
.sym
;
10301 gcc_unreachable ();
10304 comp
= gfc_get_proc_ptr_comp (expr
);
10305 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
10308 func_ifc
= comp
->ts
.interface
;
10312 if (expr
->expr_type
== EXPR_COMPCALL
)
10314 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
10315 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
10322 gcc_assert (func_ifc
->attr
.function
10323 && func_ifc
->result
!= NULL
);
10324 return func_ifc
->result
->attr
.pointer
;
10328 /* Is the lhs OK for automatic reallocation? */
10331 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
10335 /* An allocatable variable with no reference. */
10336 if (expr
->symtree
->n
.sym
->attr
.allocatable
10340 /* All that can be left are allocatable components. However, we do
10341 not check for allocatable components here because the expression
10342 could be an allocatable component of a pointer component. */
10343 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10344 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
10347 /* Find an allocatable component ref last. */
10348 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10349 if (ref
->type
== REF_COMPONENT
10351 && ref
->u
.c
.component
->attr
.allocatable
)
10358 /* Allocate or reallocate scalar lhs, as necessary. */
10361 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
10362 tree string_length
,
10370 tree size_in_bytes
;
10376 if (!expr1
|| expr1
->rank
)
10379 if (!expr2
|| expr2
->rank
)
10382 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10383 if (ref
->type
== REF_SUBSTRING
)
10386 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
10388 /* Since this is a scalar lhs, we can afford to do this. That is,
10389 there is no risk of side effects being repeated. */
10390 gfc_init_se (&lse
, NULL
);
10391 lse
.want_pointer
= 1;
10392 gfc_conv_expr (&lse
, expr1
);
10394 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10395 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10397 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10398 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
10399 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10401 tmp
= build3_v (COND_EXPR
, cond
,
10402 build1_v (GOTO_EXPR
, jump_label1
),
10403 build_empty_stmt (input_location
));
10404 gfc_add_expr_to_block (block
, tmp
);
10406 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10408 /* Use the rhs string length and the lhs element size. */
10409 size
= string_length
;
10410 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10411 tmp
= TYPE_SIZE_UNIT (tmp
);
10412 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10413 TREE_TYPE (tmp
), tmp
,
10414 fold_convert (TREE_TYPE (tmp
), size
));
10418 /* Otherwise use the length in bytes of the rhs. */
10419 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10420 size_in_bytes
= size
;
10423 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10424 size_in_bytes
, size_one_node
);
10426 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10428 tree caf_decl
, token
;
10430 symbol_attribute attr
;
10432 gfc_clear_attr (&attr
);
10433 gfc_init_se (&caf_se
, NULL
);
10435 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10436 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10438 gfc_add_block_to_block (block
, &caf_se
.pre
);
10439 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10440 gfc_build_addr_expr (NULL_TREE
, token
),
10441 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10444 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10446 tmp
= build_call_expr_loc (input_location
,
10447 builtin_decl_explicit (BUILT_IN_CALLOC
),
10448 2, build_one_cst (size_type_node
),
10450 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10451 gfc_add_modify (block
, lse
.expr
, tmp
);
10455 tmp
= build_call_expr_loc (input_location
,
10456 builtin_decl_explicit (BUILT_IN_MALLOC
),
10458 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10459 gfc_add_modify (block
, lse
.expr
, tmp
);
10462 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10464 /* Deferred characters need checking for lhs and rhs string
10465 length. Other deferred parameter variables will have to
10467 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10468 gfc_add_expr_to_block (block
, tmp
);
10470 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10471 gfc_add_expr_to_block (block
, tmp
);
10473 /* For a deferred length character, reallocate if lengths of lhs and
10474 rhs are different. */
10475 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10477 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10479 fold_convert (TREE_TYPE (lse
.string_length
),
10481 /* Jump past the realloc if the lengths are the same. */
10482 tmp
= build3_v (COND_EXPR
, cond
,
10483 build1_v (GOTO_EXPR
, jump_label2
),
10484 build_empty_stmt (input_location
));
10485 gfc_add_expr_to_block (block
, tmp
);
10486 tmp
= build_call_expr_loc (input_location
,
10487 builtin_decl_explicit (BUILT_IN_REALLOC
),
10488 2, fold_convert (pvoid_type_node
, lse
.expr
),
10490 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10491 gfc_add_modify (block
, lse
.expr
, tmp
);
10492 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10493 gfc_add_expr_to_block (block
, tmp
);
10495 /* Update the lhs character length. */
10496 size
= string_length
;
10497 gfc_add_modify (block
, lse
.string_length
,
10498 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10502 /* Check for assignments of the type
10506 to make sure we do not check for reallocation unneccessarily. */
10510 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10512 gfc_actual_arglist
*a
;
10515 switch (expr2
->expr_type
)
10517 case EXPR_VARIABLE
:
10518 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10520 case EXPR_FUNCTION
:
10521 if (expr2
->value
.function
.esym
10522 && expr2
->value
.function
.esym
->attr
.elemental
)
10524 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10527 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10532 else if (expr2
->value
.function
.isym
10533 && expr2
->value
.function
.isym
->elemental
)
10535 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10538 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10547 switch (expr2
->value
.op
.op
)
10549 case INTRINSIC_NOT
:
10550 case INTRINSIC_UPLUS
:
10551 case INTRINSIC_UMINUS
:
10552 case INTRINSIC_PARENTHESES
:
10553 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10555 case INTRINSIC_PLUS
:
10556 case INTRINSIC_MINUS
:
10557 case INTRINSIC_TIMES
:
10558 case INTRINSIC_DIVIDE
:
10559 case INTRINSIC_POWER
:
10560 case INTRINSIC_AND
:
10562 case INTRINSIC_EQV
:
10563 case INTRINSIC_NEQV
:
10570 case INTRINSIC_EQ_OS
:
10571 case INTRINSIC_NE_OS
:
10572 case INTRINSIC_GT_OS
:
10573 case INTRINSIC_GE_OS
:
10574 case INTRINSIC_LT_OS
:
10575 case INTRINSIC_LE_OS
:
10577 e1
= expr2
->value
.op
.op1
;
10578 e2
= expr2
->value
.op
.op2
;
10580 if (e1
->rank
== 0 && e2
->rank
> 0)
10581 return is_runtime_conformable (expr1
, e2
);
10582 else if (e1
->rank
> 0 && e2
->rank
== 0)
10583 return is_runtime_conformable (expr1
, e1
);
10584 else if (e1
->rank
> 0 && e2
->rank
> 0)
10585 return is_runtime_conformable (expr1
, e1
)
10586 && is_runtime_conformable (expr1
, e2
);
10604 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10605 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10606 bool class_realloc
)
10608 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
10609 vec
<tree
, va_gc
> *args
= NULL
;
10611 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10614 /* Generate allocation of the lhs. */
10620 tmp
= gfc_vptr_size_get (vptr
);
10621 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10622 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10623 gfc_init_block (&alloc
);
10624 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
10625 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10626 logical_type_node
, class_han
,
10627 build_int_cst (prvoid_type_node
, 0));
10628 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10630 PRED_FORTRAN_FAIL_ALLOC
),
10631 gfc_finish_block (&alloc
),
10632 build_empty_stmt (input_location
));
10633 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10636 fcn
= gfc_vptr_copy_get (vptr
);
10638 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10639 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10642 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10643 || INDIRECT_REF_P (tmp
)
10644 || (rhs
->ts
.type
== BT_DERIVED
10645 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10646 && !rhs
->ts
.u
.derived
->attr
.pointer
10647 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10648 || (UNLIMITED_POLY (rhs
)
10649 && !CLASS_DATA (rhs
)->attr
.pointer
10650 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10651 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10653 vec_safe_push (args
, tmp
);
10654 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10655 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10656 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10657 || INDIRECT_REF_P (tmp
)
10658 || (lhs
->ts
.type
== BT_DERIVED
10659 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10660 && !lhs
->ts
.u
.derived
->attr
.pointer
10661 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10662 || (UNLIMITED_POLY (lhs
)
10663 && !CLASS_DATA (lhs
)->attr
.pointer
10664 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10665 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10667 vec_safe_push (args
, tmp
);
10669 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10671 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10674 vec_safe_push (args
, from_len
);
10675 vec_safe_push (args
, to_len
);
10676 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10678 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10679 logical_type_node
, from_len
,
10680 build_zero_cst (TREE_TYPE (from_len
)));
10681 return fold_build3_loc (input_location
, COND_EXPR
,
10682 void_type_node
, tmp
,
10690 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10691 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10692 stmtblock_t tblock
;
10693 gfc_init_block (&tblock
);
10694 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10695 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10696 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10697 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10698 /* When coming from a ptr_copy lhs and rhs are swapped. */
10699 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10700 fold_convert (TREE_TYPE (rhst
), tmp
));
10701 return gfc_finish_block (&tblock
);
10705 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10706 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10707 init_flag indicates initialization expressions and dealloc that no
10708 deallocate prior assignment is needed (if in doubt, set true).
10709 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10710 routine instead of a pointer assignment. Alias resolution is only done,
10711 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10712 where it is known, that newly allocated memory on the lhs can never be
10713 an alias of the rhs. */
10716 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10717 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10722 gfc_ss
*lss_section
;
10729 bool scalar_to_array
;
10730 tree string_length
;
10732 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10733 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10734 bool is_poly_assign
;
10736 /* Assignment of the form lhs = rhs. */
10737 gfc_start_block (&block
);
10739 gfc_init_se (&lse
, NULL
);
10740 gfc_init_se (&rse
, NULL
);
10742 /* Walk the lhs. */
10743 lss
= gfc_walk_expr (expr1
);
10744 if (gfc_is_reallocatable_lhs (expr1
))
10746 lss
->no_bounds_check
= 1;
10747 if (!(expr2
->expr_type
== EXPR_FUNCTION
10748 && expr2
->value
.function
.isym
!= NULL
10749 && !(expr2
->value
.function
.isym
->elemental
10750 || expr2
->value
.function
.isym
->conversion
)))
10751 lss
->is_alloc_lhs
= 1;
10754 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10758 if ((expr1
->ts
.type
== BT_DERIVED
)
10759 && (gfc_is_class_array_function (expr2
)
10760 || gfc_is_alloc_class_scalar_function (expr2
)))
10761 expr2
->must_finalize
= 1;
10763 /* Checking whether a class assignment is desired is quite complicated and
10764 needed at two locations, so do it once only before the information is
10766 lhs_attr
= gfc_expr_attr (expr1
);
10767 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10768 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10769 && (expr1
->ts
.type
== BT_CLASS
10770 || gfc_is_class_array_ref (expr1
, NULL
)
10771 || gfc_is_class_scalar_expr (expr1
)
10772 || gfc_is_class_array_ref (expr2
, NULL
)
10773 || gfc_is_class_scalar_expr (expr2
));
10776 /* Only analyze the expressions for coarray properties, when in coarray-lib
10778 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10780 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10781 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10784 if (lss
!= gfc_ss_terminator
)
10786 /* The assignment needs scalarization. */
10789 /* Find a non-scalar SS from the lhs. */
10790 while (lss_section
!= gfc_ss_terminator
10791 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10792 lss_section
= lss_section
->next
;
10794 gcc_assert (lss_section
!= gfc_ss_terminator
);
10796 /* Initialize the scalarizer. */
10797 gfc_init_loopinfo (&loop
);
10799 /* Walk the rhs. */
10800 rss
= gfc_walk_expr (expr2
);
10801 if (rss
== gfc_ss_terminator
)
10802 /* The rhs is scalar. Add a ss for the expression. */
10803 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10804 /* When doing a class assign, then the handle to the rhs needs to be a
10805 pointer to allow for polymorphism. */
10806 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10807 rss
->info
->type
= GFC_SS_REFERENCE
;
10809 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10810 /* Associate the SS with the loop. */
10811 gfc_add_ss_to_loop (&loop
, lss
);
10812 gfc_add_ss_to_loop (&loop
, rss
);
10814 /* Calculate the bounds of the scalarization. */
10815 gfc_conv_ss_startstride (&loop
);
10816 /* Enable loop reversal. */
10817 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10818 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10819 /* Resolve any data dependencies in the statement. */
10821 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10822 /* Setup the scalarizing loops. */
10823 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10825 /* Setup the gfc_se structures. */
10826 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10827 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10830 gfc_mark_ss_chain_used (rss
, 1);
10831 if (loop
.temp_ss
== NULL
)
10834 gfc_mark_ss_chain_used (lss
, 1);
10838 lse
.ss
= loop
.temp_ss
;
10839 gfc_mark_ss_chain_used (lss
, 3);
10840 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10843 /* Allow the scalarizer to workshare array assignments. */
10844 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10845 == OMPWS_WORKSHARE_FLAG
10846 && loop
.temp_ss
== NULL
)
10848 maybe_workshare
= true;
10849 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10852 /* Start the scalarized loop body. */
10853 gfc_start_scalarized_body (&loop
, &body
);
10856 gfc_init_block (&body
);
10858 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10860 /* Translate the expression. */
10861 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10862 && lhs_caf_attr
.codimension
;
10863 gfc_conv_expr (&rse
, expr2
);
10865 /* Deal with the case of a scalar class function assigned to a derived type. */
10866 if (gfc_is_alloc_class_scalar_function (expr2
)
10867 && expr1
->ts
.type
== BT_DERIVED
)
10869 rse
.expr
= gfc_class_data_get (rse
.expr
);
10870 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10873 /* Stabilize a string length for temporaries. */
10874 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10875 && !(VAR_P (rse
.string_length
)
10876 || TREE_CODE (rse
.string_length
) == PARM_DECL
10877 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10878 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10879 else if (expr2
->ts
.type
== BT_CHARACTER
)
10881 if (expr1
->ts
.deferred
10882 && gfc_expr_attr (expr1
).allocatable
10883 && gfc_check_dependency (expr1
, expr2
, true))
10884 rse
.string_length
=
10885 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
10886 string_length
= rse
.string_length
;
10889 string_length
= NULL_TREE
;
10893 gfc_conv_tmp_array_ref (&lse
);
10894 if (expr2
->ts
.type
== BT_CHARACTER
)
10895 lse
.string_length
= string_length
;
10899 gfc_conv_expr (&lse
, expr1
);
10900 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10902 && gfc_expr_attr (expr1
).allocatable
10909 tmp
= INDIRECT_REF_P (lse
.expr
)
10910 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10912 /* We should only get array references here. */
10913 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10914 || TREE_CODE (tmp
) == ARRAY_REF
);
10916 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10917 or the array itself(ARRAY_REF). */
10918 tmp
= TREE_OPERAND (tmp
, 0);
10920 /* Provide the address of the array. */
10921 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10922 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10924 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10925 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10926 msg
= _("Assignment of scalar to unallocated array");
10927 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10928 &expr1
->where
, msg
);
10931 /* Deallocate the lhs parameterized components if required. */
10932 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10933 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10935 if (expr1
->ts
.type
== BT_DERIVED
10936 && expr1
->ts
.u
.derived
10937 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10939 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10941 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10943 else if (expr1
->ts
.type
== BT_CLASS
10944 && CLASS_DATA (expr1
)->ts
.u
.derived
10945 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10947 tmp
= gfc_class_data_get (lse
.expr
);
10948 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10950 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10955 /* Assignments of scalar derived types with allocatable components
10956 to arrays must be done with a deep copy and the rhs temporary
10957 must have its components deallocated afterwards. */
10958 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10959 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10960 && !gfc_expr_is_variable (expr2
)
10961 && expr1
->rank
&& !expr2
->rank
);
10962 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10964 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10965 && gfc_is_alloc_class_scalar_function (expr2
));
10966 if (scalar_to_array
&& dealloc
)
10968 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10969 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10972 /* When assigning a character function result to a deferred-length variable,
10973 the function call must happen before the (re)allocation of the lhs -
10974 otherwise the character length of the result is not known.
10975 NOTE 1: This relies on having the exact dependence of the length type
10976 parameter available to the caller; gfortran saves it in the .mod files.
10977 NOTE 2: Vector array references generate an index temporary that must
10978 not go outside the loop. Otherwise, variables should not generate
10980 NOTE 3: The concatenation operation generates a temporary pointer,
10981 whose allocation must go to the innermost loop.
10982 NOTE 4: Elemental functions may generate a temporary, too. */
10983 if (flag_realloc_lhs
10984 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10985 && !(lss
!= gfc_ss_terminator
10986 && rss
!= gfc_ss_terminator
10987 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
10988 || (expr2
->expr_type
== EXPR_FUNCTION
10989 && expr2
->value
.function
.esym
!= NULL
10990 && expr2
->value
.function
.esym
->attr
.elemental
)
10991 || (expr2
->expr_type
== EXPR_FUNCTION
10992 && expr2
->value
.function
.isym
!= NULL
10993 && expr2
->value
.function
.isym
->elemental
)
10994 || (expr2
->expr_type
== EXPR_OP
10995 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
10996 gfc_add_block_to_block (&block
, &rse
.pre
);
10998 /* Nullify the allocatable components corresponding to those of the lhs
10999 derived type, so that the finalization of the function result does not
11000 affect the lhs of the assignment. Prepend is used to ensure that the
11001 nullification occurs before the call to the finalizer. In the case of
11002 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11003 as part of the deep copy. */
11004 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11005 && (gfc_is_class_array_function (expr2
)
11006 || gfc_is_alloc_class_scalar_function (expr2
)))
11008 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11009 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11010 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11011 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11016 if (is_poly_assign
)
11017 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11018 use_vptr_copy
|| (lhs_attr
.allocatable
11019 && !lhs_attr
.dimension
),
11020 flag_realloc_lhs
&& !lhs_attr
.pointer
);
11021 else if (flag_coarray
== GFC_FCOARRAY_LIB
11022 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11023 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11024 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11026 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11027 allocatable component, because those need to be accessed via the
11028 caf-runtime. No need to check for coindexes here, because resolve
11029 has rewritten those already. */
11031 gfc_actual_arglist a1
, a2
;
11032 /* Clear the structures to prevent accessing garbage. */
11033 memset (&code
, '\0', sizeof (gfc_code
));
11034 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11035 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11040 code
.ext
.actual
= &a1
;
11041 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11042 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11044 else if (!is_poly_assign
&& expr2
->must_finalize
11045 && expr1
->ts
.type
== BT_CLASS
11046 && expr2
->ts
.type
== BT_CLASS
)
11048 /* This case comes about when the scalarizer provides array element
11049 references. Use the vptr copy function, since this does a deep
11050 copy of allocatable components, without which the finalizer call */
11051 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11052 if (tmp
!= NULL_TREE
)
11054 tree fcn
= gfc_vptr_copy_get (tmp
);
11055 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11056 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11057 tmp
= build_call_expr_loc (input_location
,
11059 gfc_build_addr_expr (NULL
, rse
.expr
),
11060 gfc_build_addr_expr (NULL
, lse
.expr
));
11064 /* If nothing else works, do it the old fashioned way! */
11065 if (tmp
== NULL_TREE
)
11066 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11067 gfc_expr_is_variable (expr2
)
11069 || expr2
->expr_type
== EXPR_ARRAY
,
11070 !(l_is_temp
|| init_flag
) && dealloc
,
11071 expr1
->symtree
->n
.sym
->attr
.codimension
);
11073 /* Add the pre blocks to the body. */
11074 gfc_add_block_to_block (&body
, &rse
.pre
);
11075 gfc_add_block_to_block (&body
, &lse
.pre
);
11076 gfc_add_expr_to_block (&body
, tmp
);
11077 /* Add the post blocks to the body. */
11078 gfc_add_block_to_block (&body
, &rse
.post
);
11079 gfc_add_block_to_block (&body
, &lse
.post
);
11081 if (lss
== gfc_ss_terminator
)
11083 /* F2003: Add the code for reallocation on assignment. */
11084 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11085 && !is_poly_assign
)
11086 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11089 /* Use the scalar assignment as is. */
11090 gfc_add_block_to_block (&block
, &body
);
11094 gcc_assert (lse
.ss
== gfc_ss_terminator
11095 && rse
.ss
== gfc_ss_terminator
);
11099 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11101 /* We need to copy the temporary to the actual lhs. */
11102 gfc_init_se (&lse
, NULL
);
11103 gfc_init_se (&rse
, NULL
);
11104 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11105 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11107 rse
.ss
= loop
.temp_ss
;
11110 gfc_conv_tmp_array_ref (&rse
);
11111 gfc_conv_expr (&lse
, expr1
);
11113 gcc_assert (lse
.ss
== gfc_ss_terminator
11114 && rse
.ss
== gfc_ss_terminator
);
11116 if (expr2
->ts
.type
== BT_CHARACTER
)
11117 rse
.string_length
= string_length
;
11119 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11121 gfc_add_expr_to_block (&body
, tmp
);
11124 /* F2003: Allocate or reallocate lhs of allocatable array. */
11125 if (flag_realloc_lhs
11126 && gfc_is_reallocatable_lhs (expr1
)
11128 && !is_runtime_conformable (expr1
, expr2
))
11130 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11131 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11132 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11133 if (tmp
!= NULL_TREE
)
11134 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11137 if (maybe_workshare
)
11138 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11140 /* Generate the copying loops. */
11141 gfc_trans_scalarizing_loops (&loop
, &body
);
11143 /* Wrap the whole thing up. */
11144 gfc_add_block_to_block (&block
, &loop
.pre
);
11145 gfc_add_block_to_block (&block
, &loop
.post
);
11147 gfc_cleanup_loop (&loop
);
11150 return gfc_finish_block (&block
);
11154 /* Check whether EXPR is a copyable array. */
11157 copyable_array_p (gfc_expr
* expr
)
11159 if (expr
->expr_type
!= EXPR_VARIABLE
)
11162 /* First check it's an array. */
11163 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11166 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11169 /* Next check that it's of a simple enough type. */
11170 switch (expr
->ts
.type
)
11182 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
11191 /* Translate an assignment. */
11194 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11195 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11199 /* Special case a single function returning an array. */
11200 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
11202 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
11207 /* Special case assigning an array to zero. */
11208 if (copyable_array_p (expr1
)
11209 && is_zero_initializer_p (expr2
))
11211 tmp
= gfc_trans_zero_assign (expr1
);
11216 /* Special case copying one array to another. */
11217 if (copyable_array_p (expr1
)
11218 && copyable_array_p (expr2
)
11219 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
11220 && !gfc_check_dependency (expr1
, expr2
, 0))
11222 tmp
= gfc_trans_array_copy (expr1
, expr2
);
11227 /* Special case initializing an array from a constant array constructor. */
11228 if (copyable_array_p (expr1
)
11229 && expr2
->expr_type
== EXPR_ARRAY
11230 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
11232 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
11237 if (UNLIMITED_POLY (expr1
) && expr1
->rank
11238 && expr2
->ts
.type
!= BT_CLASS
)
11239 use_vptr_copy
= true;
11241 /* Fallback to the scalarizer to generate explicit loops. */
11242 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
11243 use_vptr_copy
, may_alias
);
11247 gfc_trans_init_assign (gfc_code
* code
)
11249 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
11253 gfc_trans_assign (gfc_code
* code
)
11255 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);