1 /* Expression translation
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 tree desc
, type
, etype
;
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 etype
= TREE_TYPE (scalar
);
73 desc
= gfc_create_var (type
, "desc");
74 DECL_ARTIFICIAL (desc
) = 1;
76 if (CONSTANT_CLASS_P (scalar
))
79 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
80 gfc_add_modify (&se
->pre
, tmp
, scalar
);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
84 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
85 else if (TREE_TYPE (etype
) && TREE_CODE (TREE_TYPE (etype
)) == ARRAY_TYPE
)
86 etype
= TREE_TYPE (etype
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype_rank_type (0, etype
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
107 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
108 bool is_coarray
= sym
->attr
.codimension
;
109 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
110 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
114 if (ref
->type
== REF_COMPONENT
115 && (ref
->u
.c
.component
->attr
.allocatable
116 || ref
->u
.c
.component
->attr
.pointer
)
117 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
122 if (last_caf_ref
== NULL
)
125 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
127 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
128 if (comp
== NULL_TREE
&& comp_ref
)
130 gfc_init_se (&se
, outerse
);
131 gfc_free_ref_list (last_caf_ref
->next
);
132 last_caf_ref
->next
= NULL
;
133 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
134 se
.want_pointer
= comp_ref
;
135 gfc_conv_expr (&se
, caf_expr
);
136 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
138 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
139 se
.expr
= TREE_OPERAND (se
.expr
, 0);
140 gfc_free_expr (caf_expr
);
143 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
146 caf
= gfc_conv_descriptor_token (se
.expr
);
147 return gfc_build_addr_expr (NULL_TREE
, caf
);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
172 vec
<constructor_elt
, va_gc
> *init
= NULL
;
174 field
= TYPE_FIELDS (TREE_TYPE (decl
));
175 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
178 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
179 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
181 return build_constructor (TREE_TYPE (decl
), init
);
186 gfc_class_data_get (tree decl
)
189 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
190 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
191 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
193 return fold_build3_loc (input_location
, COMPONENT_REF
,
194 TREE_TYPE (data
), decl
, data
,
200 gfc_class_vptr_get (tree decl
)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
207 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
208 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
209 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
210 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
212 return fold_build3_loc (input_location
, COMPONENT_REF
,
213 TREE_TYPE (vptr
), decl
, vptr
,
219 gfc_class_len_get (tree decl
)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
226 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
227 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
228 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
229 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
231 return fold_build3_loc (input_location
, COMPONENT_REF
,
232 TREE_TYPE (len
), decl
, len
,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl
)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
248 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
249 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
250 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
251 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
253 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
254 TREE_TYPE (len
), decl
, len
,
256 : build_zero_cst (gfc_charlen_type_node
);
261 gfc_resize_class_size_with_len (stmtblock_t
* block
, tree class_expr
, tree size
)
267 tmp
= gfc_class_len_or_zero_get (class_expr
);
269 /* Include the len value in the element size if present. */
270 if (!integer_zerop (tmp
))
272 type
= TREE_TYPE (size
);
275 size
= gfc_evaluate_now (size
, block
);
276 tmp
= gfc_evaluate_now (fold_convert (type
, tmp
), block
);
278 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
280 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
281 logical_type_node
, tmp
,
282 build_zero_cst (type
));
283 size
= fold_build3_loc (input_location
, COND_EXPR
,
284 type
, tmp
, tmp2
, size
);
290 size
= gfc_evaluate_now (size
, block
);
296 /* Get the specified FIELD from the VPTR. */
299 vptr_field_get (tree vptr
, int fieldno
)
302 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
303 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
305 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
306 TREE_TYPE (field
), vptr
, field
,
313 /* Get the field from the class' vptr. */
316 class_vtab_field_get (tree decl
, int fieldno
)
319 vptr
= gfc_class_vptr_get (decl
);
320 return vptr_field_get (vptr
, fieldno
);
324 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
326 #define VTAB_GET_FIELD_GEN(name, field) tree \
327 gfc_class_vtab_## name ##_get (tree cl) \
329 return class_vtab_field_get (cl, field); \
333 gfc_vptr_## name ##_get (tree vptr) \
335 return vptr_field_get (vptr, field); \
338 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
339 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
340 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
341 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
342 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
343 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
346 /* The size field is returned as an array index type. Therefore treat
347 it and only it specially. */
350 gfc_class_vtab_size_get (tree cl
)
353 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
354 /* Always return size as an array index type. */
355 size
= fold_convert (gfc_array_index_type
, size
);
361 gfc_vptr_size_get (tree vptr
)
364 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
365 /* Always return size as an array index type. */
366 size
= fold_convert (gfc_array_index_type
, size
);
372 #undef CLASS_DATA_FIELD
373 #undef CLASS_VPTR_FIELD
374 #undef CLASS_LEN_FIELD
375 #undef VTABLE_HASH_FIELD
376 #undef VTABLE_SIZE_FIELD
377 #undef VTABLE_EXTENDS_FIELD
378 #undef VTABLE_DEF_INIT_FIELD
379 #undef VTABLE_COPY_FIELD
380 #undef VTABLE_FINAL_FIELD
383 /* Search for the last _class ref in the chain of references of this
384 expression and cut the chain there. Albeit this routine is similiar
385 to class.c::gfc_add_component_ref (), is there a significant
386 difference: gfc_add_component_ref () concentrates on an array ref to
387 be the last ref in the chain. This routine is oblivious to the kind
388 of refs following. */
391 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
, bool is_mold
)
394 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
396 /* Find the last class reference. */
399 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
401 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
404 if (ref
->type
== REF_COMPONENT
405 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
407 /* Component to the right of a part reference with nonzero rank
408 must not have the ALLOCATABLE attribute. If attempts are
409 made to reference such a component reference, an error results
410 followed by an ICE. */
411 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
416 if (ref
->next
== NULL
)
420 /* Remove and store all subsequent references after the
424 tail
= class_ref
->next
;
425 class_ref
->next
= NULL
;
427 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
434 base_expr
= gfc_expr_to_initialize (e
);
436 base_expr
= gfc_copy_expr (e
);
438 /* Restore the original tail expression. */
441 gfc_free_ref_list (class_ref
->next
);
442 class_ref
->next
= tail
;
444 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
446 gfc_free_ref_list (e
->ref
);
453 /* Reset the vptr to the declared type, e.g. after deallocation. */
456 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
463 /* Evaluate the expression and obtain the vptr from it. */
464 gfc_init_se (&se
, NULL
);
466 gfc_conv_expr_descriptor (&se
, e
);
468 gfc_conv_expr (&se
, e
);
469 gfc_add_block_to_block (block
, &se
.pre
);
470 vptr
= gfc_get_vptr_from_expr (se
.expr
);
472 /* If a vptr is not found, we can do nothing more. */
473 if (vptr
== NULL_TREE
)
476 if (UNLIMITED_POLY (e
))
477 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
480 /* Return the vptr to the address of the declared type. */
481 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
482 vtable
= vtab
->backend_decl
;
483 if (vtable
== NULL_TREE
)
484 vtable
= gfc_get_symbol_decl (vtab
);
485 vtable
= gfc_build_addr_expr (NULL
, vtable
);
486 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
487 gfc_add_modify (block
, vptr
, vtable
);
492 /* Reset the len for unlimited polymorphic objects. */
495 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
499 e
= gfc_find_and_cut_at_last_class_ref (expr
);
502 gfc_add_len_component (e
);
503 gfc_init_se (&se_len
, NULL
);
504 gfc_conv_expr (&se_len
, e
);
505 gfc_add_modify (block
, se_len
.expr
,
506 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
511 /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
512 reference is found. Note that it is up to the caller to avoid using this
513 for expressions other than variables. */
516 gfc_get_class_from_gfc_expr (gfc_expr
*e
)
518 gfc_expr
*class_expr
;
520 class_expr
= gfc_find_and_cut_at_last_class_ref (e
);
521 if (class_expr
== NULL
)
523 gfc_init_se (&cse
, NULL
);
524 gfc_conv_expr (&cse
, class_expr
);
525 gfc_free_expr (class_expr
);
530 /* Obtain the last class reference in an expression.
531 Return NULL_TREE if no class reference is found. */
534 gfc_get_class_from_expr (tree expr
)
539 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
541 if (CONSTANT_CLASS_P (tmp
))
544 type
= TREE_TYPE (tmp
);
547 if (GFC_CLASS_TYPE_P (type
))
549 if (type
!= TYPE_CANONICAL (type
))
550 type
= TYPE_CANONICAL (type
);
554 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
558 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
559 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
561 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
569 gfc_get_vptr_from_expr (tree expr
)
574 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
576 if (CONSTANT_CLASS_P (tmp
))
579 type
= TREE_TYPE (tmp
);
582 if (GFC_CLASS_TYPE_P (type
))
583 return gfc_class_vptr_get (tmp
);
584 if (type
!= TYPE_CANONICAL (type
))
585 type
= TYPE_CANONICAL (type
);
589 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
593 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
594 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
596 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
597 return gfc_class_vptr_get (tmp
);
604 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
607 tree tmp
, tmp2
, type
;
609 gfc_conv_descriptor_data_set (block
, lhs_desc
,
610 gfc_conv_descriptor_data_get (rhs_desc
));
611 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
612 gfc_conv_descriptor_offset_get (rhs_desc
));
614 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
615 gfc_conv_descriptor_dtype (rhs_desc
));
617 /* Assign the dimension as range-ref. */
618 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
619 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
621 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
622 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
623 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
624 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
625 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
626 gfc_add_modify (block
, tmp
, tmp2
);
630 /* Takes a derived type expression and returns the address of a temporary
631 class object of the 'declared' type. If vptr is not NULL, this is
632 used for the temporary class object.
633 optional_alloc_ptr is false when the dummy is neither allocatable
634 nor a pointer; that's only relevant for the optional handling. */
636 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
637 gfc_typespec class_ts
, tree vptr
, bool optional
,
638 bool optional_alloc_ptr
)
641 tree cond_optional
= NULL_TREE
;
648 /* The derived type needs to be converted to a temporary
650 tmp
= gfc_typenode_for_spec (&class_ts
);
651 var
= gfc_create_var (tmp
, "class");
654 ctree
= gfc_class_vptr_get (var
);
656 if (vptr
!= NULL_TREE
)
658 /* Use the dynamic vptr. */
663 /* In this case the vtab corresponds to the derived type and the
664 vptr must point to it. */
665 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
667 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
669 gfc_add_modify (&parmse
->pre
, ctree
,
670 fold_convert (TREE_TYPE (ctree
), tmp
));
672 /* Now set the data field. */
673 ctree
= gfc_class_data_get (var
);
676 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
678 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
680 /* If there is a ready made pointer to a derived type, use it
681 rather than evaluating the expression again. */
682 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
683 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
685 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
687 /* For an array reference in an elemental procedure call we need
688 to retain the ss to provide the scalarized array reference. */
689 gfc_conv_expr_reference (parmse
, e
);
690 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
692 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
694 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
695 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
699 ss
= gfc_walk_expr (e
);
700 if (ss
== gfc_ss_terminator
)
703 gfc_conv_expr_reference (parmse
, e
);
705 /* Scalar to an assumed-rank array. */
706 if (class_ts
.u
.derived
->components
->as
)
709 type
= get_scalar_to_descriptor_type (parmse
->expr
,
711 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
712 gfc_get_dtype (type
));
714 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
715 TREE_TYPE (parmse
->expr
),
716 cond_optional
, parmse
->expr
,
717 fold_convert (TREE_TYPE (parmse
->expr
),
719 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
723 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
725 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
727 fold_convert (TREE_TYPE (tmp
),
729 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
735 gfc_init_block (&block
);
739 parmse
->use_offset
= 1;
740 gfc_conv_expr_descriptor (parmse
, e
);
742 /* Detect any array references with vector subscripts. */
743 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
744 if (ref
->type
== REF_ARRAY
745 && ref
->u
.ar
.type
!= AR_ELEMENT
746 && ref
->u
.ar
.type
!= AR_FULL
)
748 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
749 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
751 if (dim
< ref
->u
.ar
.dimen
)
755 /* Array references with vector subscripts and non-variable expressions
756 need be converted to a one-based descriptor. */
757 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
759 for (dim
= 0; dim
< e
->rank
; ++dim
)
760 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
764 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
766 gcc_assert (class_ts
.u
.derived
->components
->as
->type
768 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
772 if (gfc_expr_attr (e
).codimension
)
773 parmse
->expr
= fold_build1_loc (input_location
,
777 gfc_add_modify (&block
, ctree
, parmse
->expr
);
782 tmp
= gfc_finish_block (&block
);
784 gfc_init_block (&block
);
785 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
787 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
788 gfc_finish_block (&block
));
789 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
792 gfc_add_block_to_block (&parmse
->pre
, &block
);
796 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
797 && class_ts
.u
.derived
->components
->ts
.u
.derived
798 ->attr
.unlimited_polymorphic
)
800 /* Take care about initializing the _len component correctly. */
801 ctree
= gfc_class_len_get (var
);
802 if (UNLIMITED_POLY (e
))
807 len
= gfc_copy_expr (e
);
808 gfc_add_len_component (len
);
809 gfc_init_se (&se
, NULL
);
810 gfc_conv_expr (&se
, len
);
812 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
813 cond_optional
, se
.expr
,
814 fold_convert (TREE_TYPE (se
.expr
),
820 tmp
= integer_zero_node
;
821 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
824 /* Pass the address of the class object. */
825 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
827 if (optional
&& optional_alloc_ptr
)
828 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
829 TREE_TYPE (parmse
->expr
),
830 cond_optional
, parmse
->expr
,
831 fold_convert (TREE_TYPE (parmse
->expr
),
836 /* Create a new class container, which is required as scalar coarrays
837 have an array descriptor while normal scalars haven't. Optionally,
838 NULL pointer checks are added if the argument is OPTIONAL. */
841 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
842 gfc_typespec class_ts
, bool optional
)
844 tree var
, ctree
, tmp
;
849 gfc_init_block (&block
);
852 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
854 if (ref
->type
== REF_COMPONENT
855 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
859 if (class_ref
== NULL
860 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
861 tmp
= e
->symtree
->n
.sym
->backend_decl
;
864 /* Remove everything after the last class reference, convert the
865 expression and then recover its tailend once more. */
867 ref
= class_ref
->next
;
868 class_ref
->next
= NULL
;
869 gfc_init_se (&tmpse
, NULL
);
870 gfc_conv_expr (&tmpse
, e
);
871 class_ref
->next
= ref
;
875 var
= gfc_typenode_for_spec (&class_ts
);
876 var
= gfc_create_var (var
, "class");
878 ctree
= gfc_class_vptr_get (var
);
879 gfc_add_modify (&block
, ctree
,
880 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
882 ctree
= gfc_class_data_get (var
);
883 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
884 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
886 /* Pass the address of the class object. */
887 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
891 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
894 tmp
= gfc_finish_block (&block
);
896 gfc_init_block (&block
);
897 tmp2
= gfc_class_data_get (var
);
898 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
900 tmp2
= gfc_finish_block (&block
);
902 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
904 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
907 gfc_add_block_to_block (&parmse
->pre
, &block
);
911 /* Takes an intrinsic type expression and returns the address of a temporary
912 class object of the 'declared' type. */
914 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
915 gfc_typespec class_ts
)
923 /* The intrinsic type needs to be converted to a temporary
925 tmp
= gfc_typenode_for_spec (&class_ts
);
926 var
= gfc_create_var (tmp
, "class");
929 ctree
= gfc_class_vptr_get (var
);
931 vtab
= gfc_find_vtab (&e
->ts
);
933 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
934 gfc_add_modify (&parmse
->pre
, ctree
,
935 fold_convert (TREE_TYPE (ctree
), tmp
));
937 /* Now set the data field. */
938 ctree
= gfc_class_data_get (var
);
939 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
941 /* For an array reference in an elemental procedure call we need
942 to retain the ss to provide the scalarized array reference. */
943 gfc_conv_expr_reference (parmse
, e
);
944 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
945 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
949 ss
= gfc_walk_expr (e
);
950 if (ss
== gfc_ss_terminator
)
953 gfc_conv_expr_reference (parmse
, e
);
954 if (class_ts
.u
.derived
->components
->as
955 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
957 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
959 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
960 TREE_TYPE (ctree
), tmp
);
963 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
964 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
969 parmse
->use_offset
= 1;
970 gfc_conv_expr_descriptor (parmse
, e
);
971 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
973 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
974 TREE_TYPE (ctree
), parmse
->expr
);
975 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
978 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
982 gcc_assert (class_ts
.type
== BT_CLASS
);
983 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
984 && class_ts
.u
.derived
->components
->ts
.u
.derived
985 ->attr
.unlimited_polymorphic
)
987 ctree
= gfc_class_len_get (var
);
988 /* When the actual arg is a char array, then set the _len component of the
989 unlimited polymorphic entity to the length of the string. */
990 if (e
->ts
.type
== BT_CHARACTER
)
992 /* Start with parmse->string_length because this seems to be set to a
993 correct value more often. */
994 if (parmse
->string_length
)
995 tmp
= parmse
->string_length
;
996 /* When the string_length is not yet set, then try the backend_decl of
998 else if (e
->ts
.u
.cl
->backend_decl
)
999 tmp
= e
->ts
.u
.cl
->backend_decl
;
1000 /* If both of the above approaches fail, then try to generate an
1001 expression from the input, which is only feasible currently, when the
1002 expression can be evaluated to a constant one. */
1005 /* Try to simplify the expression. */
1006 gfc_simplify_expr (e
, 0);
1007 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
1009 /* Amazingly all data is present to compute the length of a
1010 constant string, but the expression is not yet there. */
1011 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
1012 gfc_charlen_int_kind
,
1014 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
1015 e
->value
.character
.length
);
1016 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1017 e
->ts
.u
.cl
->resolved
= 1;
1018 tmp
= e
->ts
.u
.cl
->backend_decl
;
1022 gfc_error ("Cannot compute the length of the char array "
1023 "at %L.", &e
->where
);
1028 tmp
= integer_zero_node
;
1030 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
1032 else if (class_ts
.type
== BT_CLASS
1033 && class_ts
.u
.derived
->components
1034 && class_ts
.u
.derived
->components
->ts
.u
1035 .derived
->attr
.unlimited_polymorphic
)
1037 ctree
= gfc_class_len_get (var
);
1038 gfc_add_modify (&parmse
->pre
, ctree
,
1039 fold_convert (TREE_TYPE (ctree
),
1040 integer_zero_node
));
1042 /* Pass the address of the class object. */
1043 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1047 /* Takes a scalarized class array expression and returns the
1048 address of a temporary scalar class object of the 'declared'
1050 OOP-TODO: This could be improved by adding code that branched on
1051 the dynamic type being the same as the declared type. In this case
1052 the original class expression can be passed directly.
1053 optional_alloc_ptr is false when the dummy is neither allocatable
1054 nor a pointer; that's relevant for the optional handling.
1055 Set copyback to true if class container's _data and _vtab pointers
1056 might get modified. */
1059 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
1060 bool elemental
, bool copyback
, bool optional
,
1061 bool optional_alloc_ptr
)
1067 tree cond
= NULL_TREE
;
1068 tree slen
= NULL_TREE
;
1072 bool full_array
= false;
1074 gfc_init_block (&block
);
1077 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1079 if (ref
->type
== REF_COMPONENT
1080 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1083 if (ref
->next
== NULL
)
1087 if ((ref
== NULL
|| class_ref
== ref
)
1088 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1089 && (!class_ts
.u
.derived
->components
->as
1090 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1093 /* Test for FULL_ARRAY. */
1094 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1095 && gfc_expr_attr (e
).dimension
)
1098 gfc_is_class_array_ref (e
, &full_array
);
1100 /* The derived type needs to be converted to a temporary
1102 tmp
= gfc_typenode_for_spec (&class_ts
);
1103 var
= gfc_create_var (tmp
, "class");
1106 ctree
= gfc_class_data_get (var
);
1107 if (class_ts
.u
.derived
->components
->as
1108 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1112 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1114 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1115 gfc_get_dtype (type
));
1117 tmp
= gfc_class_data_get (parmse
->expr
);
1118 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1119 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1121 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1124 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1128 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1129 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1130 TREE_TYPE (ctree
), parmse
->expr
);
1131 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1134 /* Return the data component, except in the case of scalarized array
1135 references, where nullification of the cannot occur and so there
1137 if (!elemental
&& full_array
&& copyback
)
1139 if (class_ts
.u
.derived
->components
->as
1140 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1143 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1144 gfc_conv_descriptor_data_get (ctree
));
1146 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1149 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1153 ctree
= gfc_class_vptr_get (var
);
1155 /* The vptr is the second field of the actual argument.
1156 First we have to find the corresponding class reference. */
1159 if (gfc_is_class_array_function (e
)
1160 && parmse
->class_vptr
!= NULL_TREE
)
1161 tmp
= parmse
->class_vptr
;
1162 else if (class_ref
== NULL
1163 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1165 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1167 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1168 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1170 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1171 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1173 slen
= build_zero_cst (size_type_node
);
1177 /* Remove everything after the last class reference, convert the
1178 expression and then recover its tailend once more. */
1180 ref
= class_ref
->next
;
1181 class_ref
->next
= NULL
;
1182 gfc_init_se (&tmpse
, NULL
);
1183 gfc_conv_expr (&tmpse
, e
);
1184 class_ref
->next
= ref
;
1186 slen
= tmpse
.string_length
;
1189 gcc_assert (tmp
!= NULL_TREE
);
1191 /* Dereference if needs be. */
1192 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1193 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1195 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1196 vptr
= gfc_class_vptr_get (tmp
);
1200 gfc_add_modify (&block
, ctree
,
1201 fold_convert (TREE_TYPE (ctree
), vptr
));
1203 /* Return the vptr component, except in the case of scalarized array
1204 references, where the dynamic type cannot change. */
1205 if (!elemental
&& full_array
&& copyback
)
1206 gfc_add_modify (&parmse
->post
, vptr
,
1207 fold_convert (TREE_TYPE (vptr
), ctree
));
1209 /* For unlimited polymorphic objects also set the _len component. */
1210 if (class_ts
.type
== BT_CLASS
1211 && class_ts
.u
.derived
->components
1212 && class_ts
.u
.derived
->components
->ts
.u
1213 .derived
->attr
.unlimited_polymorphic
)
1215 ctree
= gfc_class_len_get (var
);
1216 if (UNLIMITED_POLY (e
))
1217 tmp
= gfc_class_len_get (tmp
);
1218 else if (e
->ts
.type
== BT_CHARACTER
)
1220 gcc_assert (slen
!= NULL_TREE
);
1224 tmp
= build_zero_cst (size_type_node
);
1225 gfc_add_modify (&parmse
->pre
, ctree
,
1226 fold_convert (TREE_TYPE (ctree
), tmp
));
1228 /* Return the len component, except in the case of scalarized array
1229 references, where the dynamic type cannot change. */
1230 if (!elemental
&& full_array
&& copyback
1231 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1232 gfc_add_modify (&parmse
->post
, tmp
,
1233 fold_convert (TREE_TYPE (tmp
), ctree
));
1240 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1241 /* parmse->pre may contain some preparatory instructions for the
1242 temporary array descriptor. Those may only be executed when the
1243 optional argument is set, therefore add parmse->pre's instructions
1244 to block, which is later guarded by an if (optional_arg_given). */
1245 gfc_add_block_to_block (&parmse
->pre
, &block
);
1246 block
.head
= parmse
->pre
.head
;
1247 parmse
->pre
.head
= NULL_TREE
;
1248 tmp
= gfc_finish_block (&block
);
1250 if (optional_alloc_ptr
)
1251 tmp2
= build_empty_stmt (input_location
);
1254 gfc_init_block (&block
);
1256 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1257 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1258 null_pointer_node
));
1259 tmp2
= gfc_finish_block (&block
);
1262 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1264 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1267 gfc_add_block_to_block (&parmse
->pre
, &block
);
1269 /* Pass the address of the class object. */
1270 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1272 if (optional
&& optional_alloc_ptr
)
1273 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1274 TREE_TYPE (parmse
->expr
),
1276 fold_convert (TREE_TYPE (parmse
->expr
),
1277 null_pointer_node
));
1281 /* Given a class array declaration and an index, returns the address
1282 of the referenced element. */
1285 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1288 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1290 data
= data_comp
!= NULL_TREE
? data_comp
:
1291 gfc_class_data_get (class_decl
);
1292 size
= gfc_class_vtab_size_get (class_decl
);
1296 tmp
= fold_convert (gfc_array_index_type
,
1297 gfc_class_len_get (class_decl
));
1298 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1299 gfc_array_index_type
, size
, tmp
);
1300 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1301 logical_type_node
, tmp
,
1302 build_zero_cst (TREE_TYPE (tmp
)));
1303 size
= fold_build3_loc (input_location
, COND_EXPR
,
1304 gfc_array_index_type
, tmp
, ctmp
, size
);
1307 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1308 gfc_array_index_type
,
1311 data
= gfc_conv_descriptor_data_get (data
);
1312 ptr
= fold_convert (pvoid_type_node
, data
);
1313 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1314 return fold_convert (TREE_TYPE (data
), ptr
);
1318 /* Copies one class expression to another, assuming that if either
1319 'to' or 'from' are arrays they are packed. Should 'from' be
1320 NULL_TREE, the initialization expression for 'to' is used, assuming
1321 that the _vptr is set. */
1324 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1334 vec
<tree
, va_gc
> *args
;
1339 bool is_from_desc
= false, is_to_class
= false;
1342 /* To prevent warnings on uninitialized variables. */
1343 from_len
= to_len
= NULL_TREE
;
1345 if (from
!= NULL_TREE
)
1346 fcn
= gfc_class_vtab_copy_get (from
);
1348 fcn
= gfc_class_vtab_copy_get (to
);
1350 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1352 if (from
!= NULL_TREE
)
1354 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1358 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1362 /* Check that from is a class. When the class is part of a coarray,
1363 then from is a common pointer and is to be used as is. */
1364 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1365 ? build_fold_indirect_ref (from
) : from
;
1367 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1368 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1369 ? gfc_class_data_get (from
) : from
;
1370 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1374 from_data
= gfc_class_vtab_def_init_get (to
);
1378 if (from
!= NULL_TREE
&& unlimited
)
1379 from_len
= gfc_class_len_or_zero_get (from
);
1381 from_len
= build_zero_cst (size_type_node
);
1384 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1387 to_data
= gfc_class_data_get (to
);
1389 to_len
= gfc_class_len_get (to
);
1392 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1395 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1397 stmtblock_t loopbody
;
1401 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1403 gfc_init_block (&body
);
1404 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1405 gfc_array_index_type
, nelems
,
1406 gfc_index_one_node
);
1407 nelems
= gfc_evaluate_now (tmp
, &body
);
1408 index
= gfc_create_var (gfc_array_index_type
, "S");
1412 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1414 vec_safe_push (args
, from_ref
);
1417 vec_safe_push (args
, from_data
);
1420 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1423 tmp
= gfc_conv_array_data (to
);
1424 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1425 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1426 gfc_build_array_ref (tmp
, index
, to
));
1428 vec_safe_push (args
, to_ref
);
1430 /* Add bounds check. */
1431 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1434 const char *name
= "<<unknown>>";
1438 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1440 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1441 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1442 logical_type_node
, from_len
, orig_nelems
);
1443 msg
= xasprintf ("Array bound mismatch for dimension %d "
1444 "of array '%s' (%%ld/%%ld)",
1447 gfc_trans_runtime_check (true, false, tmp
, &body
,
1448 &gfc_current_locus
, msg
,
1449 fold_convert (long_integer_type_node
, orig_nelems
),
1450 fold_convert (long_integer_type_node
, from_len
));
1455 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1457 /* Build the body of the loop. */
1458 gfc_init_block (&loopbody
);
1459 gfc_add_expr_to_block (&loopbody
, tmp
);
1461 /* Build the loop and return. */
1462 gfc_init_loopinfo (&loop
);
1464 loop
.from
[0] = gfc_index_zero_node
;
1465 loop
.loopvar
[0] = index
;
1466 loop
.to
[0] = nelems
;
1467 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1468 gfc_init_block (&ifbody
);
1469 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1470 stdcopy
= gfc_finish_block (&ifbody
);
1471 /* In initialization mode from_len is a constant zero. */
1472 if (unlimited
&& !integer_zerop (from_len
))
1474 vec_safe_push (args
, from_len
);
1475 vec_safe_push (args
, to_len
);
1476 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1477 /* Build the body of the loop. */
1478 gfc_init_block (&loopbody
);
1479 gfc_add_expr_to_block (&loopbody
, tmp
);
1481 /* Build the loop and return. */
1482 gfc_init_loopinfo (&loop
);
1484 loop
.from
[0] = gfc_index_zero_node
;
1485 loop
.loopvar
[0] = index
;
1486 loop
.to
[0] = nelems
;
1487 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1488 gfc_init_block (&ifbody
);
1489 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1490 extcopy
= gfc_finish_block (&ifbody
);
1492 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1493 logical_type_node
, from_len
,
1494 build_zero_cst (TREE_TYPE (from_len
)));
1495 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1496 void_type_node
, tmp
, extcopy
, stdcopy
);
1497 gfc_add_expr_to_block (&body
, tmp
);
1498 tmp
= gfc_finish_block (&body
);
1502 gfc_add_expr_to_block (&body
, stdcopy
);
1503 tmp
= gfc_finish_block (&body
);
1505 gfc_cleanup_loop (&loop
);
1509 gcc_assert (!is_from_desc
);
1510 vec_safe_push (args
, from_data
);
1511 vec_safe_push (args
, to_data
);
1512 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1514 /* In initialization mode from_len is a constant zero. */
1515 if (unlimited
&& !integer_zerop (from_len
))
1517 vec_safe_push (args
, from_len
);
1518 vec_safe_push (args
, to_len
);
1519 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1520 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1521 logical_type_node
, from_len
,
1522 build_zero_cst (TREE_TYPE (from_len
)));
1523 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1524 void_type_node
, tmp
, extcopy
, stdcopy
);
1530 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1531 if (from
== NULL_TREE
)
1534 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1536 from_data
, null_pointer_node
);
1537 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1538 void_type_node
, cond
,
1539 tmp
, build_empty_stmt (input_location
));
1547 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1549 gfc_actual_arglist
*actual
;
1554 actual
= gfc_get_actual_arglist ();
1555 actual
->expr
= gfc_copy_expr (rhs
);
1556 actual
->next
= gfc_get_actual_arglist ();
1557 actual
->next
->expr
= gfc_copy_expr (lhs
);
1558 ppc
= gfc_copy_expr (obj
);
1559 gfc_add_vptr_component (ppc
);
1560 gfc_add_component_ref (ppc
, "_copy");
1561 ppc_code
= gfc_get_code (EXEC_CALL
);
1562 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1563 /* Although '_copy' is set to be elemental in class.c, it is
1564 not staying that way. Find out why, sometime.... */
1565 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1566 ppc_code
->ext
.actual
= actual
;
1567 ppc_code
->expr1
= ppc
;
1568 /* Since '_copy' is elemental, the scalarizer will take care
1569 of arrays in gfc_trans_call. */
1570 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1571 gfc_free_statements (ppc_code
);
1573 if (UNLIMITED_POLY(obj
))
1575 /* Check if rhs is non-NULL. */
1577 gfc_init_se (&src
, NULL
);
1578 gfc_conv_expr (&src
, rhs
);
1579 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1580 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1581 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1582 null_pointer_node
));
1583 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1584 build_empty_stmt (input_location
));
1590 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1591 A MEMCPY is needed to copy the full data from the default initializer
1592 of the dynamic type. */
1595 gfc_trans_class_init_assign (gfc_code
*code
)
1599 gfc_se dst
,src
,memsz
;
1600 gfc_expr
*lhs
, *rhs
, *sz
;
1602 gfc_start_block (&block
);
1604 lhs
= gfc_copy_expr (code
->expr1
);
1606 rhs
= gfc_copy_expr (code
->expr1
);
1607 gfc_add_vptr_component (rhs
);
1609 /* Make sure that the component backend_decls have been built, which
1610 will not have happened if the derived types concerned have not
1612 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1613 gfc_add_def_init_component (rhs
);
1614 /* The _def_init is always scalar. */
1617 if (code
->expr1
->ts
.type
== BT_CLASS
1618 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1620 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1621 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1622 /* Adding the array ref to the class expression results in correct
1623 indexing to the dynamic type. */
1624 gfc_add_full_array_ref (lhs
, tmparr
);
1625 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1629 /* Scalar initialization needs the _data component. */
1630 gfc_add_data_component (lhs
);
1631 sz
= gfc_copy_expr (code
->expr1
);
1632 gfc_add_vptr_component (sz
);
1633 gfc_add_size_component (sz
);
1635 gfc_init_se (&dst
, NULL
);
1636 gfc_init_se (&src
, NULL
);
1637 gfc_init_se (&memsz
, NULL
);
1638 gfc_conv_expr (&dst
, lhs
);
1639 gfc_conv_expr (&src
, rhs
);
1640 gfc_conv_expr (&memsz
, sz
);
1641 gfc_add_block_to_block (&block
, &src
.pre
);
1642 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1644 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1646 if (UNLIMITED_POLY(code
->expr1
))
1648 /* Check if _def_init is non-NULL. */
1649 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1650 logical_type_node
, src
.expr
,
1651 fold_convert (TREE_TYPE (src
.expr
),
1652 null_pointer_node
));
1653 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1654 tmp
, build_empty_stmt (input_location
));
1658 if (code
->expr1
->symtree
->n
.sym
->attr
.dummy
1659 && (code
->expr1
->symtree
->n
.sym
->attr
.optional
1660 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
))
1662 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1663 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1665 build_empty_stmt (input_location
));
1668 gfc_add_expr_to_block (&block
, tmp
);
1670 return gfc_finish_block (&block
);
1674 /* Class valued elemental function calls or class array elements arriving
1675 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1676 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1679 trans_scalar_class_assign (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
)
1688 stmtblock_t inner_block
;
1690 bool not_call_expr
= TREE_CODE (rse
->expr
) != CALL_EXPR
;
1691 bool not_lhs_array_type
;
1693 /* Temporaries arising from depencies in assignment get cast as a
1694 character type of the dynamic size of the rhs. Use the vptr copy
1696 tmp
= TREE_TYPE (lse
->expr
);
1697 not_lhs_array_type
= !(tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
1698 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) != NULL_TREE
);
1700 /* Use ordinary assignment if the rhs is not a call expression or
1701 the lhs is not a class entity or an array(ie. character) type. */
1702 if ((not_call_expr
&& gfc_get_class_from_expr (lse
->expr
) == NULL_TREE
)
1703 && not_lhs_array_type
)
1706 /* Ordinary assignment can be used if both sides are class expressions
1707 since the dynamic type is preserved by copying the vptr. This
1708 should only occur, where temporaries are involved. */
1709 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
1710 && GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
1713 /* Fix the class expression and the class data of the rhs. */
1714 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
1717 tmp
= gfc_get_class_from_expr (rse
->expr
);
1718 if (tmp
== NULL_TREE
)
1720 rse_expr
= gfc_evaluate_now (tmp
, block
);
1723 rse_expr
= gfc_evaluate_now (rse
->expr
, block
);
1725 class_data
= gfc_class_data_get (rse_expr
);
1727 /* Check that the rhs data is not null. */
1728 is_descriptor
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data
));
1730 class_data
= gfc_conv_descriptor_data_get (class_data
);
1731 class_data
= gfc_evaluate_now (class_data
, block
);
1733 zero
= build_int_cst (TREE_TYPE (class_data
), 0);
1734 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1738 /* Copy the rhs to the lhs. */
1739 fcn
= gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr
));
1740 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1741 tmp
= gfc_evaluate_now (gfc_build_addr_expr (NULL
, rse
->expr
), block
);
1742 tmp
= is_descriptor
? tmp
: class_data
;
1743 tmp
= build_call_expr_loc (input_location
, fcn
, 2, tmp
,
1744 gfc_build_addr_expr (NULL
, lse
->expr
));
1745 gfc_add_expr_to_block (block
, tmp
);
1747 /* Only elemental function results need to be finalised and freed. */
1751 /* Finalize the class data if needed. */
1752 gfc_init_block (&inner_block
);
1753 fcn
= gfc_vptr_final_get (gfc_class_vptr_get (rse_expr
));
1754 zero
= build_int_cst (TREE_TYPE (fcn
), 0);
1755 final_cond
= fold_build2_loc (input_location
, NE_EXPR
,
1756 logical_type_node
, fcn
, zero
);
1757 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1758 tmp
= build_call_expr_loc (input_location
, fcn
, 1, class_data
);
1759 tmp
= build3_v (COND_EXPR
, final_cond
,
1760 tmp
, build_empty_stmt (input_location
));
1761 gfc_add_expr_to_block (&inner_block
, tmp
);
1763 /* Free the class data. */
1764 tmp
= gfc_call_free (class_data
);
1765 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1766 build_empty_stmt (input_location
));
1767 gfc_add_expr_to_block (&inner_block
, tmp
);
1769 /* Finish the inner block and subject it to the condition on the
1770 class data being non-zero. */
1771 tmp
= gfc_finish_block (&inner_block
);
1772 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1773 build_empty_stmt (input_location
));
1774 gfc_add_expr_to_block (block
, tmp
);
1779 /* End of prototype trans-class.c */
1783 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1785 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1786 gfc_warning (OPT_Wrealloc_lhs
,
1787 "Code for reallocating the allocatable array at %L will "
1789 else if (warn_realloc_lhs_all
)
1790 gfc_warning (OPT_Wrealloc_lhs_all
,
1791 "Code for reallocating the allocatable variable at %L "
1792 "will be added", where
);
1796 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1799 /* Copy the scalarization loop variables. */
1802 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1805 dest
->loop
= src
->loop
;
1809 /* Initialize a simple expression holder.
1811 Care must be taken when multiple se are created with the same parent.
1812 The child se must be kept in sync. The easiest way is to delay creation
1813 of a child se until after after the previous se has been translated. */
1816 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1818 memset (se
, 0, sizeof (gfc_se
));
1819 gfc_init_block (&se
->pre
);
1820 gfc_init_block (&se
->post
);
1822 se
->parent
= parent
;
1825 gfc_copy_se_loopvars (se
, parent
);
1829 /* Advances to the next SS in the chain. Use this rather than setting
1830 se->ss = se->ss->next because all the parents needs to be kept in sync.
1834 gfc_advance_se_ss_chain (gfc_se
* se
)
1839 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1842 /* Walk down the parent chain. */
1845 /* Simple consistency check. */
1846 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1847 || p
->parent
->ss
->nested_ss
== p
->ss
);
1849 /* If we were in a nested loop, the next scalarized expression can be
1850 on the parent ss' next pointer. Thus we should not take the next
1851 pointer blindly, but rather go up one nest level as long as next
1852 is the end of chain. */
1854 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1864 /* Ensures the result of the expression as either a temporary variable
1865 or a constant so that it can be used repeatedly. */
1868 gfc_make_safe_expr (gfc_se
* se
)
1872 if (CONSTANT_CLASS_P (se
->expr
))
1875 /* We need a temporary for this result. */
1876 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1877 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1882 /* Return an expression which determines if a dummy parameter is present.
1883 Also used for arguments to procedures with multiple entry points. */
1886 gfc_conv_expr_present (gfc_symbol
* sym
)
1890 gcc_assert (sym
->attr
.dummy
);
1891 decl
= gfc_get_symbol_decl (sym
);
1893 /* Intrinsic scalars with VALUE attribute which are passed by value
1894 use a hidden argument to denote the present status. */
1895 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1896 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1897 && !sym
->attr
.dimension
)
1899 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1902 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1904 strcpy (&name
[1], sym
->name
);
1905 tree_name
= get_identifier (name
);
1907 /* Walk function argument list to find hidden arg. */
1908 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1909 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1910 if (DECL_NAME (cond
) == tree_name
)
1917 if (TREE_CODE (decl
) != PARM_DECL
)
1919 /* Array parameters use a temporary descriptor, we want the real
1921 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1922 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1923 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1926 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1927 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1929 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1930 as actual argument to denote absent dummies. For array descriptors,
1931 we thus also need to check the array descriptor. For BT_CLASS, it
1932 can also occur for scalars and F2003 due to type->class wrapping and
1933 class->class wrapping. Note further that BT_CLASS always uses an
1934 array descriptor for arrays, also for explicit-shape/assumed-size. */
1936 if (!sym
->attr
.allocatable
1937 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1938 || (sym
->ts
.type
== BT_CLASS
1939 && !CLASS_DATA (sym
)->attr
.allocatable
1940 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1941 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1942 || sym
->ts
.type
== BT_CLASS
))
1946 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1947 || sym
->as
->type
== AS_ASSUMED_RANK
1948 || sym
->attr
.codimension
))
1949 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1951 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1952 if (sym
->ts
.type
== BT_CLASS
)
1953 tmp
= gfc_class_data_get (tmp
);
1954 tmp
= gfc_conv_array_data (tmp
);
1956 else if (sym
->ts
.type
== BT_CLASS
)
1957 tmp
= gfc_class_data_get (decl
);
1961 if (tmp
!= NULL_TREE
)
1963 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1964 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1965 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1966 logical_type_node
, cond
, tmp
);
1974 /* Converts a missing, dummy argument into a null or zero. */
1977 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1982 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1986 /* Create a temporary and convert it to the correct type. */
1987 tmp
= gfc_get_int_type (kind
);
1988 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1991 /* Test for a NULL value. */
1992 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1993 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1994 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1995 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1999 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
2001 build_zero_cst (TREE_TYPE (se
->expr
)));
2002 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2006 if (ts
.type
== BT_CHARACTER
)
2008 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2009 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
2010 present
, se
->string_length
, tmp
);
2011 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2012 se
->string_length
= tmp
;
2018 /* Get the character length of an expression, looking through gfc_refs
2022 gfc_get_expr_charlen (gfc_expr
*e
)
2028 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2029 && e
->ts
.type
== BT_CHARACTER
);
2031 length
= NULL
; /* To silence compiler warning. */
2033 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
2036 gfc_init_se (&tmpse
, NULL
);
2037 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
2038 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
2042 /* First candidate: if the variable is of type CHARACTER, the
2043 expression's length could be the length of the character
2045 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2046 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2048 /* Look through the reference chain for component references. */
2049 for (r
= e
->ref
; r
; r
= r
->next
)
2054 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
2055 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
2063 gfc_init_se (&se
, NULL
);
2064 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
2066 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
2067 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
2068 gfc_charlen_type_node
,
2070 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
2071 gfc_charlen_type_node
, length
,
2072 gfc_index_one_node
);
2081 gcc_assert (length
!= NULL
);
2086 /* Return for an expression the backend decl of the coarray. */
2089 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
2095 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
2097 /* Not-implemented diagnostic. */
2098 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
2099 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
2100 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2101 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2102 "%L is not supported", &expr
->where
);
2104 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2105 if (ref
->type
== REF_COMPONENT
)
2107 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
2108 && UNLIMITED_POLY (ref
->u
.c
.component
)
2109 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
2110 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2111 "component at %L is not supported", &expr
->where
);
2114 /* Make sure the backend_decl is present before accessing it. */
2115 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
2116 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
2117 : expr
->symtree
->n
.sym
->backend_decl
;
2119 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2121 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
2123 caf_decl
= gfc_class_data_get (caf_decl
);
2124 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2127 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2129 if (ref
->type
== REF_COMPONENT
2130 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
2132 caf_decl
= gfc_class_data_get (caf_decl
);
2133 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2137 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
2141 if (expr
->symtree
->n
.sym
->attr
.codimension
)
2144 /* The following code assumes that the coarray is a component reachable via
2145 only scalar components/variables; the Fortran standard guarantees this. */
2147 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2148 if (ref
->type
== REF_COMPONENT
)
2150 gfc_component
*comp
= ref
->u
.c
.component
;
2152 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
2153 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2154 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2155 TREE_TYPE (comp
->backend_decl
), caf_decl
,
2156 comp
->backend_decl
, NULL_TREE
);
2157 if (comp
->ts
.type
== BT_CLASS
)
2159 caf_decl
= gfc_class_data_get (caf_decl
);
2160 if (CLASS_DATA (comp
)->attr
.codimension
)
2166 if (comp
->attr
.codimension
)
2172 gcc_assert (found
&& caf_decl
);
2177 /* Obtain the Coarray token - and optionally also the offset. */
2180 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2181 tree se_expr
, gfc_expr
*expr
)
2185 /* Coarray token. */
2186 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2188 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2189 == GFC_ARRAY_ALLOCATABLE
2190 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2191 *token
= gfc_conv_descriptor_token (caf_decl
);
2193 else if (DECL_LANG_SPECIFIC (caf_decl
)
2194 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2195 *token
= GFC_DECL_TOKEN (caf_decl
);
2198 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2199 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2200 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2206 /* Offset between the coarray base address and the address wanted. */
2207 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2208 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2209 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2210 *offset
= build_int_cst (gfc_array_index_type
, 0);
2211 else if (DECL_LANG_SPECIFIC (caf_decl
)
2212 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2213 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2214 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2215 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2217 *offset
= build_int_cst (gfc_array_index_type
, 0);
2219 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2220 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2222 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2223 tmp
= gfc_conv_descriptor_data_get (tmp
);
2225 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2226 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2229 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2233 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2234 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2236 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2237 && expr
->symtree
->n
.sym
->attr
.codimension
2238 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2240 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2241 gfc_ref
*ref
= base_expr
->ref
;
2244 // Iterate through the refs until the last one.
2248 if (ref
->type
== REF_ARRAY
2249 && ref
->u
.ar
.type
!= AR_FULL
)
2251 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2253 for (i
= 0; i
< ranksum
; ++i
)
2255 ref
->u
.ar
.start
[i
] = NULL
;
2256 ref
->u
.ar
.end
[i
] = NULL
;
2258 ref
->u
.ar
.type
= AR_FULL
;
2260 gfc_init_se (&base_se
, NULL
);
2261 if (gfc_caf_attr (base_expr
).dimension
)
2263 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2264 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2268 gfc_conv_expr (&base_se
, base_expr
);
2272 gfc_free_expr (base_expr
);
2273 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2274 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2276 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2277 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2280 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2284 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2285 fold_convert (gfc_array_index_type
, *offset
),
2286 fold_convert (gfc_array_index_type
, tmp
));
2290 /* Convert the coindex of a coarray into an image index; the result is
2291 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2292 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2295 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2298 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2302 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2303 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2305 gcc_assert (ref
!= NULL
);
2307 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2309 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2313 img_idx
= build_zero_cst (gfc_array_index_type
);
2314 extent
= build_one_cst (gfc_array_index_type
);
2315 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2316 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2318 gfc_init_se (&se
, NULL
);
2319 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2320 gfc_add_block_to_block (block
, &se
.pre
);
2321 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2322 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2323 TREE_TYPE (lbound
), se
.expr
, lbound
);
2324 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2326 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2327 TREE_TYPE (tmp
), img_idx
, tmp
);
2328 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2330 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2331 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2332 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2333 TREE_TYPE (tmp
), extent
, tmp
);
2337 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2339 gfc_init_se (&se
, NULL
);
2340 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2341 gfc_add_block_to_block (block
, &se
.pre
);
2342 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2343 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2344 TREE_TYPE (lbound
), se
.expr
, lbound
);
2345 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2347 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2349 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2351 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2352 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2353 TREE_TYPE (ubound
), ubound
, lbound
);
2354 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2355 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2356 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2357 TREE_TYPE (tmp
), extent
, tmp
);
2360 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2361 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2362 return fold_convert (integer_type_node
, img_idx
);
2366 /* For each character array constructor subexpression without a ts.u.cl->length,
2367 replace it by its first element (if there aren't any elements, the length
2368 should already be set to zero). */
2371 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2373 gfc_actual_arglist
* arg
;
2379 switch (e
->expr_type
)
2383 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2384 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2388 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2392 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2393 flatten_array_ctors_without_strlen (arg
->expr
);
2398 /* We've found what we're looking for. */
2399 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2404 gcc_assert (e
->value
.constructor
);
2406 c
= gfc_constructor_first (e
->value
.constructor
);
2410 flatten_array_ctors_without_strlen (new_expr
);
2411 gfc_replace_expr (e
, new_expr
);
2415 /* Otherwise, fall through to handle constructor elements. */
2417 case EXPR_STRUCTURE
:
2418 for (c
= gfc_constructor_first (e
->value
.constructor
);
2419 c
; c
= gfc_constructor_next (c
))
2420 flatten_array_ctors_without_strlen (c
->expr
);
2430 /* Generate code to initialize a string length variable. Returns the
2431 value. For array constructors, cl->length might be NULL and in this case,
2432 the first element of the constructor is needed. expr is the original
2433 expression so we can access it but can be NULL if this is not needed. */
2436 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2440 gfc_init_se (&se
, NULL
);
2442 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2445 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2446 "flatten" array constructors by taking their first element; all elements
2447 should be the same length or a cl->length should be present. */
2450 gfc_expr
* expr_flat
;
2453 expr_flat
= gfc_copy_expr (expr
);
2454 flatten_array_ctors_without_strlen (expr_flat
);
2455 gfc_resolve_expr (expr_flat
);
2457 gfc_conv_expr (&se
, expr_flat
);
2458 gfc_add_block_to_block (pblock
, &se
.pre
);
2459 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2461 gfc_free_expr (expr_flat
);
2465 /* Convert cl->length. */
2467 gcc_assert (cl
->length
);
2469 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2470 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2471 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2472 gfc_add_block_to_block (pblock
, &se
.pre
);
2474 if (cl
->backend_decl
)
2475 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2477 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2482 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2483 const char *name
, locus
*where
)
2493 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2494 type
= build_pointer_type (type
);
2496 gfc_init_se (&start
, se
);
2497 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2498 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2500 if (integer_onep (start
.expr
))
2501 gfc_conv_string_parameter (se
);
2506 /* Avoid multiple evaluation of substring start. */
2507 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2508 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2510 /* Change the start of the string. */
2511 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2514 tmp
= build_fold_indirect_ref_loc (input_location
,
2516 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2517 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2520 /* Length = end + 1 - start. */
2521 gfc_init_se (&end
, se
);
2522 if (ref
->u
.ss
.end
== NULL
)
2523 end
.expr
= se
->string_length
;
2526 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2527 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2531 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2532 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2534 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2536 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2537 logical_type_node
, start
.expr
,
2540 /* Check lower bound. */
2541 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2543 build_one_cst (TREE_TYPE (start
.expr
)));
2544 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2545 logical_type_node
, nonempty
, fault
);
2547 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2548 "is less than one", name
);
2550 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2551 "is less than one");
2552 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2553 fold_convert (long_integer_type_node
,
2557 /* Check upper bound. */
2558 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2559 end
.expr
, se
->string_length
);
2560 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2561 logical_type_node
, nonempty
, fault
);
2563 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2564 "exceeds string length (%%ld)", name
);
2566 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2567 "exceeds string length (%%ld)");
2568 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2569 fold_convert (long_integer_type_node
, end
.expr
),
2570 fold_convert (long_integer_type_node
,
2571 se
->string_length
));
2575 /* Try to calculate the length from the start and end expressions. */
2577 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2579 HOST_WIDE_INT i_len
;
2581 i_len
= gfc_mpz_get_hwi (length
) + 1;
2585 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2586 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2590 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2591 fold_convert (gfc_charlen_type_node
, end
.expr
),
2592 fold_convert (gfc_charlen_type_node
, start
.expr
));
2593 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2594 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2595 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2596 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2599 se
->string_length
= tmp
;
2603 /* Convert a derived type component reference. */
2606 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2614 c
= ref
->u
.c
.component
;
2616 if (c
->backend_decl
== NULL_TREE
2617 && ref
->u
.c
.sym
!= NULL
)
2618 gfc_get_derived_type (ref
->u
.c
.sym
);
2620 field
= c
->backend_decl
;
2621 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2623 context
= DECL_FIELD_CONTEXT (field
);
2625 /* Components can correspond to fields of different containing
2626 types, as components are created without context, whereas
2627 a concrete use of a component has the type of decl as context.
2628 So, if the type doesn't match, we search the corresponding
2629 FIELD_DECL in the parent type. To not waste too much time
2630 we cache this result in norestrict_decl.
2631 On the other hand, if the context is a UNION or a MAP (a
2632 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2634 if (context
!= TREE_TYPE (decl
)
2635 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2636 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2638 tree f2
= c
->norestrict_decl
;
2639 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2640 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2641 if (TREE_CODE (f2
) == FIELD_DECL
2642 && DECL_NAME (f2
) == DECL_NAME (field
))
2645 c
->norestrict_decl
= f2
;
2649 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2650 && strcmp ("_data", c
->name
) == 0)
2652 /* Found a ref to the _data component. Store the associated ref to
2653 the vptr in se->class_vptr. */
2654 se
->class_vptr
= gfc_class_vptr_get (decl
);
2657 se
->class_vptr
= NULL_TREE
;
2659 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2660 decl
, field
, NULL_TREE
);
2664 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2665 strlen () conditional below. */
2666 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2668 && !c
->attr
.pdt_string
)
2670 tmp
= c
->ts
.u
.cl
->backend_decl
;
2671 /* Components must always be constant length. */
2672 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2673 se
->string_length
= tmp
;
2676 if (gfc_deferred_strlen (c
, &field
))
2678 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2680 decl
, field
, NULL_TREE
);
2681 se
->string_length
= tmp
;
2684 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2685 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2686 && c
->ts
.type
!= BT_CHARACTER
)
2687 || c
->attr
.proc_pointer
)
2688 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2693 /* This function deals with component references to components of the
2694 parent type for derived type extensions. */
2696 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2704 c
= ref
->u
.c
.component
;
2706 /* Return if the component is in the parent type. */
2707 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2708 if (strcmp (c
->name
, cmp
->name
) == 0)
2711 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2712 parent
.type
= REF_COMPONENT
;
2714 parent
.u
.c
.sym
= dt
;
2715 parent
.u
.c
.component
= dt
->components
;
2717 if (dt
->backend_decl
== NULL
)
2718 gfc_get_derived_type (dt
);
2720 /* Build the reference and call self. */
2721 gfc_conv_component_ref (se
, &parent
);
2722 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2723 parent
.u
.c
.component
= c
;
2724 conv_parent_component_references (se
, &parent
);
2729 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2731 tree res
= se
->expr
;
2736 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2737 TREE_TYPE (TREE_TYPE (res
)), res
);
2741 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2742 TREE_TYPE (TREE_TYPE (res
)), res
);
2746 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2751 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2761 /* Return the contents of a variable. Also handles reference/pointer
2762 variables (all Fortran pointer references are implicit). */
2765 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2770 tree parent_decl
= NULL_TREE
;
2773 bool alternate_entry
;
2776 bool first_time
= true;
2778 sym
= expr
->symtree
->n
.sym
;
2779 is_classarray
= IS_CLASS_ARRAY (sym
);
2783 gfc_ss_info
*ss_info
= ss
->info
;
2785 /* Check that something hasn't gone horribly wrong. */
2786 gcc_assert (ss
!= gfc_ss_terminator
);
2787 gcc_assert (ss_info
->expr
== expr
);
2789 /* A scalarized term. We already know the descriptor. */
2790 se
->expr
= ss_info
->data
.array
.descriptor
;
2791 se
->string_length
= ss_info
->string_length
;
2792 ref
= ss_info
->data
.array
.ref
;
2794 gcc_assert (ref
->type
== REF_ARRAY
2795 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2797 gfc_conv_tmp_array_ref (se
);
2801 tree se_expr
= NULL_TREE
;
2803 se
->expr
= gfc_get_symbol_decl (sym
);
2805 /* Deal with references to a parent results or entries by storing
2806 the current_function_decl and moving to the parent_decl. */
2807 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2808 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2809 && sym
->result
== sym
;
2810 entry_master
= sym
->attr
.result
2811 && sym
->ns
->proc_name
->attr
.entry_master
2812 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2813 if (current_function_decl
)
2814 parent_decl
= DECL_CONTEXT (current_function_decl
);
2816 if ((se
->expr
== parent_decl
&& return_value
)
2817 || (sym
->ns
&& sym
->ns
->proc_name
2819 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2820 && (alternate_entry
|| entry_master
)))
2825 /* Special case for assigning the return value of a function.
2826 Self recursive functions must have an explicit return value. */
2827 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2828 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2830 /* Similarly for alternate entry points. */
2831 else if (alternate_entry
2832 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2835 gfc_entry_list
*el
= NULL
;
2837 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2840 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2845 else if (entry_master
2846 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2848 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2853 /* Procedure actual arguments. Look out for temporary variables
2854 with the same attributes as function values. */
2855 else if (!sym
->attr
.temporary
2856 && sym
->attr
.flavor
== FL_PROCEDURE
2857 && se
->expr
!= current_function_decl
)
2859 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2861 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2862 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2868 /* Dereference the expression, where needed. Since characters
2869 are entirely different from other types, they are treated
2871 if (sym
->ts
.type
== BT_CHARACTER
)
2873 /* Dereference character pointer dummy arguments
2875 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2877 || sym
->attr
.function
2878 || sym
->attr
.result
))
2879 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2883 else if (!sym
->attr
.value
)
2885 /* Dereference temporaries for class array dummy arguments. */
2886 if (sym
->attr
.dummy
&& is_classarray
2887 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2889 if (!se
->descriptor_only
)
2890 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2892 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2896 /* Dereference non-character scalar dummy arguments. */
2897 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2898 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2899 && (sym
->ts
.type
!= BT_CLASS
2900 || (!CLASS_DATA (sym
)->attr
.dimension
2901 && !(CLASS_DATA (sym
)->attr
.codimension
2902 && CLASS_DATA (sym
)->attr
.allocatable
))))
2903 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2906 /* Dereference scalar hidden result. */
2907 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2908 && (sym
->attr
.function
|| sym
->attr
.result
)
2909 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2910 && !sym
->attr
.always_explicit
)
2911 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2914 /* Dereference non-character, non-class pointer variables.
2915 These must be dummies, results, or scalars. */
2917 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2918 || gfc_is_associate_pointer (sym
)
2919 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2921 || sym
->attr
.function
2923 || (!sym
->attr
.dimension
2924 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2925 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2927 /* Now treat the class array pointer variables accordingly. */
2928 else if (sym
->ts
.type
== BT_CLASS
2930 && (CLASS_DATA (sym
)->attr
.dimension
2931 || CLASS_DATA (sym
)->attr
.codimension
)
2932 && ((CLASS_DATA (sym
)->as
2933 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2934 || CLASS_DATA (sym
)->attr
.allocatable
2935 || CLASS_DATA (sym
)->attr
.class_pointer
))
2936 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2938 /* And the case where a non-dummy, non-result, non-function,
2939 non-allotable and non-pointer classarray is present. This case was
2940 previously covered by the first if, but with introducing the
2941 condition !is_classarray there, that case has to be covered
2943 else if (sym
->ts
.type
== BT_CLASS
2945 && !sym
->attr
.function
2946 && !sym
->attr
.result
2947 && (CLASS_DATA (sym
)->attr
.dimension
2948 || CLASS_DATA (sym
)->attr
.codimension
)
2950 || !CLASS_DATA (sym
)->attr
.allocatable
)
2951 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2952 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2959 /* For character variables, also get the length. */
2960 if (sym
->ts
.type
== BT_CHARACTER
)
2962 /* If the character length of an entry isn't set, get the length from
2963 the master function instead. */
2964 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2965 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2967 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2968 gcc_assert (se
->string_length
);
2971 gfc_typespec
*ts
= &sym
->ts
;
2977 /* Return the descriptor if that's what we want and this is an array
2978 section reference. */
2979 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2981 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2982 /* Return the descriptor for array pointers and allocations. */
2983 if (se
->want_pointer
2984 && ref
->next
== NULL
&& (se
->descriptor_only
))
2987 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2988 /* Return a pointer to an element. */
2992 ts
= &ref
->u
.c
.component
->ts
;
2993 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2994 && se
->descriptor_only
2995 && !CLASS_DATA (sym
)->attr
.allocatable
2996 && !CLASS_DATA (sym
)->attr
.class_pointer
2997 && CLASS_DATA (sym
)->as
2998 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2999 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
3000 /* Skip the first ref of a _data component, because for class
3001 arrays that one is already done by introducing a temporary
3002 array descriptor. */
3005 if (ref
->u
.c
.sym
->attr
.extension
)
3006 conv_parent_component_references (se
, ref
);
3008 gfc_conv_component_ref (se
, ref
);
3009 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
3010 && se
->want_pointer
&& se
->descriptor_only
)
3016 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
3017 expr
->symtree
->name
, &expr
->where
);
3021 conv_inquiry (se
, ref
, expr
, ts
);
3031 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3033 if (se
->want_pointer
)
3035 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
3036 gfc_conv_string_parameter (se
);
3038 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3043 /* Unary ops are easy... Or they would be if ! was a valid op. */
3046 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
3051 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3052 /* Initialize the operand. */
3053 gfc_init_se (&operand
, se
);
3054 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
3055 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
3057 type
= gfc_typenode_for_spec (&expr
->ts
);
3059 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3060 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3061 All other unary operators have an equivalent GIMPLE unary operator. */
3062 if (code
== TRUTH_NOT_EXPR
)
3063 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
3064 build_int_cst (type
, 0));
3066 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
3070 /* Expand power operator to optimal multiplications when a value is raised
3071 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3072 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3073 Programming", 3rd Edition, 1998. */
3075 /* This code is mostly duplicated from expand_powi in the backend.
3076 We establish the "optimal power tree" lookup table with the defined size.
3077 The items in the table are the exponents used to calculate the index
3078 exponents. Any integer n less than the value can get an "addition chain",
3079 with the first node being one. */
3080 #define POWI_TABLE_SIZE 256
3082 /* The table is from builtins.c. */
3083 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
3085 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3086 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3087 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3088 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3089 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3090 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3091 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3092 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3093 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3094 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3095 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3096 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3097 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3098 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3099 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3100 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3101 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3102 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3103 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3104 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3105 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3106 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3107 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3108 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3109 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3110 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3111 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3112 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3113 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3114 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3115 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3116 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3119 /* If n is larger than lookup table's max index, we use the "window
3121 #define POWI_WINDOW_SIZE 3
3123 /* Recursive function to expand the power operator. The temporary
3124 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3126 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
3133 if (n
< POWI_TABLE_SIZE
)
3138 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
3139 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
3143 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
3144 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
3145 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
3149 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
3153 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
3154 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3156 if (n
< POWI_TABLE_SIZE
)
3163 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3164 return 1. Else return 0 and a call to runtime library functions
3165 will have to be built. */
3167 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3172 tree vartmp
[POWI_TABLE_SIZE
];
3174 unsigned HOST_WIDE_INT n
;
3176 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3178 /* If exponent is too large, we won't expand it anyway, so don't bother
3179 with large integer values. */
3180 if (!wi::fits_shwi_p (wrhs
))
3183 m
= wrhs
.to_shwi ();
3184 /* Use the wide_int's routine to reliably get the absolute value on all
3185 platforms. Then convert it to a HOST_WIDE_INT like above. */
3186 n
= wi::abs (wrhs
).to_shwi ();
3188 type
= TREE_TYPE (lhs
);
3189 sgn
= tree_int_cst_sgn (rhs
);
3191 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3192 || optimize_size
) && (m
> 2 || m
< -1))
3198 se
->expr
= gfc_build_const (type
, integer_one_node
);
3202 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3203 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3205 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3206 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3207 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3208 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3211 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3214 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3215 logical_type_node
, tmp
, cond
);
3216 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3217 tmp
, build_int_cst (type
, 1),
3218 build_int_cst (type
, 0));
3222 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3223 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3224 build_int_cst (type
, -1),
3225 build_int_cst (type
, 0));
3226 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3227 cond
, build_int_cst (type
, 1), tmp
);
3231 memset (vartmp
, 0, sizeof (vartmp
));
3235 tmp
= gfc_build_const (type
, integer_one_node
);
3236 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3240 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3246 /* Power op (**). Constant integer exponent has special handling. */
3249 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3251 tree gfc_int4_type_node
;
3254 int res_ikind_1
, res_ikind_2
;
3259 gfc_init_se (&lse
, se
);
3260 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3261 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3262 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3264 gfc_init_se (&rse
, se
);
3265 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3266 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3268 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3269 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3270 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3273 if (INTEGER_CST_P (lse
.expr
)
3274 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3276 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3278 int kind
, ikind
, bit_size
;
3280 v
= wlhs
.to_shwi ();
3283 kind
= expr
->value
.op
.op1
->ts
.kind
;
3284 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3285 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3289 /* 1**something is always 1. */
3290 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3295 /* (-1)**n is 1 - ((n & 1) << 1) */
3299 type
= TREE_TYPE (lse
.expr
);
3300 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3301 rse
.expr
, build_int_cst (type
, 1));
3302 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3303 tmp
, build_int_cst (type
, 1));
3304 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3305 build_int_cst (type
, 1), tmp
);
3309 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3311 /* Here v is +/- 2**e. The further simplification uses
3312 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3313 1<<(4*n), etc., but we have to make sure to return zero
3314 if the number of bits is too large. */
3324 type
= TREE_TYPE (lse
.expr
);
3329 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3330 TREE_TYPE (rse
.expr
),
3331 rse
.expr
, rse
.expr
);
3334 /* use popcount for fast log2(w) */
3335 int e
= wi::popcount (w
-1);
3336 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3337 TREE_TYPE (rse
.expr
),
3338 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3342 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3343 build_int_cst (type
, 1), shift
);
3344 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3345 rse
.expr
, build_int_cst (type
, 0));
3346 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3347 build_int_cst (type
, 0));
3348 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3349 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3350 rse
.expr
, num_bits
);
3351 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3352 build_int_cst (type
, 0), cond
);
3359 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3361 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3362 rse
.expr
, build_int_cst (type
, 1));
3363 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3364 tmp2
, build_int_cst (type
, 1));
3365 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3366 build_int_cst (type
, 1), tmp2
);
3367 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3374 gfc_int4_type_node
= gfc_get_int_type (4);
3376 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3377 library routine. But in the end, we have to convert the result back
3378 if this case applies -- with res_ikind_K, we keep track whether operand K
3379 falls into this case. */
3383 kind
= expr
->value
.op
.op1
->ts
.kind
;
3384 switch (expr
->value
.op
.op2
->ts
.type
)
3387 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3392 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3393 res_ikind_2
= ikind
;
3415 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3417 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3444 switch (expr
->value
.op
.op1
->ts
.type
)
3447 if (kind
== 3) /* Case 16 was not handled properly above. */
3449 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3453 /* Use builtins for real ** int4. */
3459 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3463 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3467 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3471 /* Use the __builtin_powil() only if real(kind=16) is
3472 actually the C long double type. */
3473 if (!gfc_real16_is_float128
)
3474 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3482 /* If we don't have a good builtin for this, go for the
3483 library function. */
3485 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3489 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3498 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3502 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3510 se
->expr
= build_call_expr_loc (input_location
,
3511 fndecl
, 2, lse
.expr
, rse
.expr
);
3513 /* Convert the result back if it is of wrong integer kind. */
3514 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3516 /* We want the maximum of both operand kinds as result. */
3517 if (res_ikind_1
< res_ikind_2
)
3518 res_ikind_1
= res_ikind_2
;
3519 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3524 /* Generate code to allocate a string temporary. */
3527 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3532 if (gfc_can_put_var_on_stack (len
))
3534 /* Create a temporary variable to hold the result. */
3535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3536 TREE_TYPE (len
), len
,
3537 build_int_cst (TREE_TYPE (len
), 1));
3538 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3540 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3541 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3543 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3545 var
= gfc_create_var (tmp
, "str");
3546 var
= gfc_build_addr_expr (type
, var
);
3550 /* Allocate a temporary to hold the result. */
3551 var
= gfc_create_var (type
, "pstr");
3552 gcc_assert (POINTER_TYPE_P (type
));
3553 tmp
= TREE_TYPE (type
);
3554 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3555 tmp
= TREE_TYPE (tmp
);
3556 tmp
= TYPE_SIZE_UNIT (tmp
);
3557 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3558 fold_convert (size_type_node
, len
),
3559 fold_convert (size_type_node
, tmp
));
3560 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3561 gfc_add_modify (&se
->pre
, var
, tmp
);
3563 /* Free the temporary afterwards. */
3564 tmp
= gfc_call_free (var
);
3565 gfc_add_expr_to_block (&se
->post
, tmp
);
3572 /* Handle a string concatenation operation. A temporary will be allocated to
3576 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3579 tree len
, type
, var
, tmp
, fndecl
;
3581 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3582 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3583 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3585 gfc_init_se (&lse
, se
);
3586 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3587 gfc_conv_string_parameter (&lse
);
3588 gfc_init_se (&rse
, se
);
3589 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3590 gfc_conv_string_parameter (&rse
);
3592 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3593 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3595 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3596 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3597 if (len
== NULL_TREE
)
3599 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3600 gfc_charlen_type_node
,
3601 fold_convert (gfc_charlen_type_node
,
3603 fold_convert (gfc_charlen_type_node
,
3604 rse
.string_length
));
3607 type
= build_pointer_type (type
);
3609 var
= gfc_conv_string_tmp (se
, type
, len
);
3611 /* Do the actual concatenation. */
3612 if (expr
->ts
.kind
== 1)
3613 fndecl
= gfor_fndecl_concat_string
;
3614 else if (expr
->ts
.kind
== 4)
3615 fndecl
= gfor_fndecl_concat_string_char4
;
3619 tmp
= build_call_expr_loc (input_location
,
3620 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3621 rse
.string_length
, rse
.expr
);
3622 gfc_add_expr_to_block (&se
->pre
, tmp
);
3624 /* Add the cleanup for the operands. */
3625 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3626 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3629 se
->string_length
= len
;
3632 /* Translates an op expression. Common (binary) cases are handled by this
3633 function, others are passed on. Recursion is used in either case.
3634 We use the fact that (op1.ts == op2.ts) (except for the power
3636 Operators need no special handling for scalarized expressions as long as
3637 they call gfc_conv_simple_val to get their operands.
3638 Character strings get special handling. */
3641 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3643 enum tree_code code
;
3652 switch (expr
->value
.op
.op
)
3654 case INTRINSIC_PARENTHESES
:
3655 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3656 && flag_protect_parens
)
3658 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3659 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3664 case INTRINSIC_UPLUS
:
3665 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3668 case INTRINSIC_UMINUS
:
3669 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3673 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3676 case INTRINSIC_PLUS
:
3680 case INTRINSIC_MINUS
:
3684 case INTRINSIC_TIMES
:
3688 case INTRINSIC_DIVIDE
:
3689 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3690 an integer, we must round towards zero, so we use a
3692 if (expr
->ts
.type
== BT_INTEGER
)
3693 code
= TRUNC_DIV_EXPR
;
3698 case INTRINSIC_POWER
:
3699 gfc_conv_power_op (se
, expr
);
3702 case INTRINSIC_CONCAT
:
3703 gfc_conv_concat_op (se
, expr
);
3707 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3712 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3716 /* EQV and NEQV only work on logicals, but since we represent them
3717 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3719 case INTRINSIC_EQ_OS
:
3727 case INTRINSIC_NE_OS
:
3728 case INTRINSIC_NEQV
:
3735 case INTRINSIC_GT_OS
:
3742 case INTRINSIC_GE_OS
:
3749 case INTRINSIC_LT_OS
:
3756 case INTRINSIC_LE_OS
:
3762 case INTRINSIC_USER
:
3763 case INTRINSIC_ASSIGN
:
3764 /* These should be converted into function calls by the frontend. */
3768 fatal_error (input_location
, "Unknown intrinsic op");
3772 /* The only exception to this is **, which is handled separately anyway. */
3773 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3775 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3779 gfc_init_se (&lse
, se
);
3780 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3781 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3784 gfc_init_se (&rse
, se
);
3785 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3786 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3790 gfc_conv_string_parameter (&lse
);
3791 gfc_conv_string_parameter (&rse
);
3793 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3794 rse
.string_length
, rse
.expr
,
3795 expr
->value
.op
.op1
->ts
.kind
,
3797 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3798 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3801 type
= gfc_typenode_for_spec (&expr
->ts
);
3805 /* The result of logical ops is always logical_type_node. */
3806 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3807 lse
.expr
, rse
.expr
);
3808 se
->expr
= convert (type
, tmp
);
3811 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3813 /* Add the post blocks. */
3814 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3815 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3818 /* If a string's length is one, we convert it to a single character. */
3821 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3825 || !tree_fits_uhwi_p (len
)
3826 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3829 if (TREE_INT_CST_LOW (len
) == 1)
3831 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3832 return build_fold_indirect_ref_loc (input_location
, str
);
3836 && TREE_CODE (str
) == ADDR_EXPR
3837 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3838 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3839 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3840 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3841 && TREE_INT_CST_LOW (len
) > 1
3842 && TREE_INT_CST_LOW (len
)
3843 == (unsigned HOST_WIDE_INT
)
3844 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3846 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3847 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3848 if (TREE_CODE (ret
) == INTEGER_CST
)
3850 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3851 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3852 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3854 for (i
= 1; i
< length
; i
++)
3867 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3870 if (sym
->backend_decl
)
3872 /* This becomes the nominal_type in
3873 function.c:assign_parm_find_data_types. */
3874 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3875 /* This becomes the passed_type in
3876 function.c:assign_parm_find_data_types. C promotes char to
3877 integer for argument passing. */
3878 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3880 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3885 /* If we have a constant character expression, make it into an
3887 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3892 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3893 (int)(*expr
)->value
.character
.string
[0]);
3894 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3896 /* The expr needs to be compatible with a C int. If the
3897 conversion fails, then the 2 causes an ICE. */
3898 ts
.type
= BT_INTEGER
;
3899 ts
.kind
= gfc_c_int_kind
;
3900 gfc_convert_type (*expr
, &ts
, 2);
3903 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3905 if ((*expr
)->ref
== NULL
)
3907 se
->expr
= gfc_string_to_single_character
3908 (build_int_cst (integer_type_node
, 1),
3909 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3911 ((*expr
)->symtree
->n
.sym
)),
3916 gfc_conv_variable (se
, *expr
);
3917 se
->expr
= gfc_string_to_single_character
3918 (build_int_cst (integer_type_node
, 1),
3919 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3927 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3928 if STR is a string literal, otherwise return -1. */
3931 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3934 && TREE_CODE (str
) == ADDR_EXPR
3935 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3936 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3937 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3938 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3939 && tree_fits_uhwi_p (len
)
3940 && tree_to_uhwi (len
) >= 1
3941 && tree_to_uhwi (len
)
3942 == (unsigned HOST_WIDE_INT
)
3943 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3945 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3946 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3947 if (TREE_CODE (folded
) == INTEGER_CST
)
3949 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3950 int length
= TREE_STRING_LENGTH (string_cst
);
3951 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3953 for (; length
> 0; length
--)
3954 if (ptr
[length
- 1] != ' ')
3963 /* Helper to build a call to memcmp. */
3966 build_memcmp_call (tree s1
, tree s2
, tree n
)
3970 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3971 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3973 s1
= fold_convert (pvoid_type_node
, s1
);
3975 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3976 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3978 s2
= fold_convert (pvoid_type_node
, s2
);
3980 n
= fold_convert (size_type_node
, n
);
3982 tmp
= build_call_expr_loc (input_location
,
3983 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3986 return fold_convert (integer_type_node
, tmp
);
3989 /* Compare two strings. If they are all single characters, the result is the
3990 subtraction of them. Otherwise, we build a library call. */
3993 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3994 enum tree_code code
)
4000 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
4001 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
4003 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
4004 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
4006 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
4008 /* Deal with single character specially. */
4009 sc1
= fold_convert (integer_type_node
, sc1
);
4010 sc2
= fold_convert (integer_type_node
, sc2
);
4011 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4015 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
4017 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
4019 /* If one string is a string literal with LEN_TRIM longer
4020 than the length of the second string, the strings
4022 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
4023 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
4024 return integer_one_node
;
4025 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
4026 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
4027 return integer_one_node
;
4030 /* We can compare via memcpy if the strings are known to be equal
4031 in length and they are
4033 - kind=4 and the comparison is for (in)equality. */
4035 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
4036 && tree_int_cst_equal (len1
, len2
)
4037 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
4042 chartype
= gfc_get_char_type (kind
);
4043 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
4044 fold_convert (TREE_TYPE(len1
),
4045 TYPE_SIZE_UNIT(chartype
)),
4047 return build_memcmp_call (str1
, str2
, tmp
);
4050 /* Build a call for the comparison. */
4052 fndecl
= gfor_fndecl_compare_string
;
4054 fndecl
= gfor_fndecl_compare_string_char4
;
4058 return build_call_expr_loc (input_location
, fndecl
, 4,
4059 len1
, str1
, len2
, str2
);
4063 /* Return the backend_decl for a procedure pointer component. */
4066 get_proc_ptr_comp (gfc_expr
*e
)
4072 gfc_init_se (&comp_se
, NULL
);
4073 e2
= gfc_copy_expr (e
);
4074 /* We have to restore the expr type later so that gfc_free_expr frees
4075 the exact same thing that was allocated.
4076 TODO: This is ugly. */
4077 old_type
= e2
->expr_type
;
4078 e2
->expr_type
= EXPR_VARIABLE
;
4079 gfc_conv_expr (&comp_se
, e2
);
4080 e2
->expr_type
= old_type
;
4082 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
4086 /* Convert a typebound function reference from a class object. */
4088 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
4093 if (!VAR_P (base_object
))
4095 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
4096 gfc_add_modify (&se
->pre
, var
, base_object
);
4098 se
->expr
= gfc_class_vptr_get (base_object
);
4099 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4101 while (ref
&& ref
->next
)
4103 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
4104 if (ref
->u
.c
.sym
->attr
.extension
)
4105 conv_parent_component_references (se
, ref
);
4106 gfc_conv_component_ref (se
, ref
);
4107 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
4112 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
4113 gfc_actual_arglist
*actual_args
)
4117 if (gfc_is_proc_ptr_comp (expr
))
4118 tmp
= get_proc_ptr_comp (expr
);
4119 else if (sym
->attr
.dummy
)
4121 tmp
= gfc_get_symbol_decl (sym
);
4122 if (sym
->attr
.proc_pointer
)
4123 tmp
= build_fold_indirect_ref_loc (input_location
,
4125 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
4126 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
4130 if (!sym
->backend_decl
)
4131 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
4133 TREE_USED (sym
->backend_decl
) = 1;
4135 tmp
= sym
->backend_decl
;
4137 if (sym
->attr
.cray_pointee
)
4139 /* TODO - make the cray pointee a pointer to a procedure,
4140 assign the pointer to it and use it for the call. This
4142 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
4143 gfc_get_symbol_decl (sym
->cp_pointer
));
4144 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4147 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
4149 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
4150 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4157 /* Initialize MAPPING. */
4160 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
4162 mapping
->syms
= NULL
;
4163 mapping
->charlens
= NULL
;
4167 /* Free all memory held by MAPPING (but not MAPPING itself). */
4170 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4172 gfc_interface_sym_mapping
*sym
;
4173 gfc_interface_sym_mapping
*nextsym
;
4175 gfc_charlen
*nextcl
;
4177 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4179 nextsym
= sym
->next
;
4180 sym
->new_sym
->n
.sym
->formal
= NULL
;
4181 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4182 gfc_free_expr (sym
->expr
);
4183 free (sym
->new_sym
);
4186 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4189 gfc_free_expr (cl
->length
);
4195 /* Return a copy of gfc_charlen CL. Add the returned structure to
4196 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4198 static gfc_charlen
*
4199 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4202 gfc_charlen
*new_charlen
;
4204 new_charlen
= gfc_get_charlen ();
4205 new_charlen
->next
= mapping
->charlens
;
4206 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4208 mapping
->charlens
= new_charlen
;
4213 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4214 array variable that can be used as the actual argument for dummy
4215 argument SYM. Add any initialization code to BLOCK. PACKED is as
4216 for gfc_get_nodesc_array_type and DATA points to the first element
4217 in the passed array. */
4220 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4221 gfc_packed packed
, tree data
)
4226 type
= gfc_typenode_for_spec (&sym
->ts
);
4227 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4228 !sym
->attr
.target
&& !sym
->attr
.pointer
4229 && !sym
->attr
.proc_pointer
);
4231 var
= gfc_create_var (type
, "ifm");
4232 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4238 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4239 and offset of descriptorless array type TYPE given that it has the same
4240 size as DESC. Add any set-up code to BLOCK. */
4243 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4250 offset
= gfc_index_zero_node
;
4251 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4253 dim
= gfc_rank_cst
[n
];
4254 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4255 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4257 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4258 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4259 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4260 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4262 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4264 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4265 gfc_array_index_type
,
4266 gfc_conv_descriptor_ubound_get (desc
, dim
),
4267 gfc_conv_descriptor_lbound_get (desc
, dim
));
4268 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4269 gfc_array_index_type
,
4270 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4271 tmp
= gfc_evaluate_now (tmp
, block
);
4272 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4274 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4275 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4276 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4277 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4278 gfc_array_index_type
, offset
, tmp
);
4280 offset
= gfc_evaluate_now (offset
, block
);
4281 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4285 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4286 in SE. The caller may still use se->expr and se->string_length after
4287 calling this function. */
4290 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4291 gfc_symbol
* sym
, gfc_se
* se
,
4294 gfc_interface_sym_mapping
*sm
;
4298 gfc_symbol
*new_sym
;
4300 gfc_symtree
*new_symtree
;
4302 /* Create a new symbol to represent the actual argument. */
4303 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4304 new_sym
->ts
= sym
->ts
;
4305 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4306 new_sym
->attr
.referenced
= 1;
4307 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4308 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4309 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4310 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4311 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4312 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4313 new_sym
->attr
.function
= sym
->attr
.function
;
4315 /* Ensure that the interface is available and that
4316 descriptors are passed for array actual arguments. */
4317 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4319 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4320 new_sym
->attr
.always_explicit
4321 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4324 /* Create a fake symtree for it. */
4326 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4327 new_symtree
->n
.sym
= new_sym
;
4328 gcc_assert (new_symtree
== root
);
4330 /* Create a dummy->actual mapping. */
4331 sm
= XCNEW (gfc_interface_sym_mapping
);
4332 sm
->next
= mapping
->syms
;
4334 sm
->new_sym
= new_symtree
;
4335 sm
->expr
= gfc_copy_expr (expr
);
4338 /* Stabilize the argument's value. */
4339 if (!sym
->attr
.function
&& se
)
4340 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4342 if (sym
->ts
.type
== BT_CHARACTER
)
4344 /* Create a copy of the dummy argument's length. */
4345 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4346 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4348 /* If the length is specified as "*", record the length that
4349 the caller is passing. We should use the callee's length
4350 in all other cases. */
4351 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4353 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4354 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4361 /* Use the passed value as-is if the argument is a function. */
4362 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4365 /* If the argument is a pass-by-value scalar, use the value as is. */
4366 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4369 /* If the argument is either a string or a pointer to a string,
4370 convert it to a boundless character type. */
4371 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4373 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4374 tmp
= build_pointer_type (tmp
);
4375 if (sym
->attr
.pointer
)
4376 value
= build_fold_indirect_ref_loc (input_location
,
4380 value
= fold_convert (tmp
, value
);
4383 /* If the argument is a scalar, a pointer to an array or an allocatable,
4385 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4386 value
= build_fold_indirect_ref_loc (input_location
,
4389 /* For character(*), use the actual argument's descriptor. */
4390 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4391 value
= build_fold_indirect_ref_loc (input_location
,
4394 /* If the argument is an array descriptor, use it to determine
4395 information about the actual argument's shape. */
4396 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4397 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4399 /* Get the actual argument's descriptor. */
4400 desc
= build_fold_indirect_ref_loc (input_location
,
4403 /* Create the replacement variable. */
4404 tmp
= gfc_conv_descriptor_data_get (desc
);
4405 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4408 /* Use DESC to work out the upper bounds, strides and offset. */
4409 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4412 /* Otherwise we have a packed array. */
4413 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4414 PACKED_FULL
, se
->expr
);
4416 new_sym
->backend_decl
= value
;
4420 /* Called once all dummy argument mappings have been added to MAPPING,
4421 but before the mapping is used to evaluate expressions. Pre-evaluate
4422 the length of each argument, adding any initialization code to PRE and
4423 any finalization code to POST. */
4426 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4427 stmtblock_t
* pre
, stmtblock_t
* post
)
4429 gfc_interface_sym_mapping
*sym
;
4433 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4434 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4435 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4437 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4438 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4439 gfc_init_se (&se
, NULL
);
4440 gfc_conv_expr (&se
, expr
);
4441 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4442 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4443 gfc_add_block_to_block (pre
, &se
.pre
);
4444 gfc_add_block_to_block (post
, &se
.post
);
4446 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4451 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4455 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4456 gfc_constructor_base base
)
4459 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4461 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4464 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4465 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4466 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4472 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4476 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4481 for (; ref
; ref
= ref
->next
)
4485 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4487 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4488 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4489 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4498 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4499 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4505 /* Convert intrinsic function calls into result expressions. */
4508 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4516 arg1
= expr
->value
.function
.actual
->expr
;
4517 if (expr
->value
.function
.actual
->next
)
4518 arg2
= expr
->value
.function
.actual
->next
->expr
;
4522 sym
= arg1
->symtree
->n
.sym
;
4524 if (sym
->attr
.dummy
)
4529 switch (expr
->value
.function
.isym
->id
)
4532 /* TODO figure out why this condition is necessary. */
4533 if (sym
->attr
.function
4534 && (arg1
->ts
.u
.cl
->length
== NULL
4535 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4536 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4539 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4542 case GFC_ISYM_LEN_TRIM
:
4543 new_expr
= gfc_copy_expr (arg1
);
4544 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4549 gfc_replace_expr (arg1
, new_expr
);
4553 if (!sym
->as
|| sym
->as
->rank
== 0)
4556 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4558 dup
= mpz_get_si (arg2
->value
.integer
);
4563 dup
= sym
->as
->rank
;
4567 for (; d
< dup
; d
++)
4571 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4573 gfc_free_expr (new_expr
);
4577 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4578 gfc_get_int_expr (gfc_default_integer_kind
,
4580 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4582 new_expr
= gfc_multiply (new_expr
, tmp
);
4588 case GFC_ISYM_LBOUND
:
4589 case GFC_ISYM_UBOUND
:
4590 /* TODO These implementations of lbound and ubound do not limit if
4591 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4593 if (!sym
->as
|| sym
->as
->rank
== 0)
4596 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4597 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4601 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4603 if (sym
->as
->lower
[d
])
4604 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4608 if (sym
->as
->upper
[d
])
4609 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4617 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4621 gfc_replace_expr (expr
, new_expr
);
4627 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4628 gfc_interface_mapping
* mapping
)
4630 gfc_formal_arglist
*f
;
4631 gfc_actual_arglist
*actual
;
4633 actual
= expr
->value
.function
.actual
;
4634 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4636 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4641 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4644 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4649 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4651 for (d
= 0; d
< as
->rank
; d
++)
4653 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4654 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4657 expr
->value
.function
.esym
->as
= as
;
4660 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4662 expr
->value
.function
.esym
->ts
.u
.cl
->length
4663 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4665 gfc_apply_interface_mapping_to_expr (mapping
,
4666 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4671 /* EXPR is a copy of an expression that appeared in the interface
4672 associated with MAPPING. Walk it recursively looking for references to
4673 dummy arguments that MAPPING maps to actual arguments. Replace each such
4674 reference with a reference to the associated actual argument. */
4677 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4680 gfc_interface_sym_mapping
*sym
;
4681 gfc_actual_arglist
*actual
;
4686 /* Copying an expression does not copy its length, so do that here. */
4687 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4689 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4690 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4693 /* Apply the mapping to any references. */
4694 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4696 /* ...and to the expression's symbol, if it has one. */
4697 /* TODO Find out why the condition on expr->symtree had to be moved into
4698 the loop rather than being outside it, as originally. */
4699 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4700 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4702 if (sym
->new_sym
->n
.sym
->backend_decl
)
4703 expr
->symtree
= sym
->new_sym
;
4705 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4708 /* ...and to subexpressions in expr->value. */
4709 switch (expr
->expr_type
)
4714 case EXPR_SUBSTRING
:
4718 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4719 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4723 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4724 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4726 if (expr
->value
.function
.esym
== NULL
4727 && expr
->value
.function
.isym
!= NULL
4728 && expr
->value
.function
.actual
4729 && expr
->value
.function
.actual
->expr
4730 && expr
->value
.function
.actual
->expr
->symtree
4731 && gfc_map_intrinsic_function (expr
, mapping
))
4734 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4735 if (sym
->old
== expr
->value
.function
.esym
)
4737 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4738 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4739 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4744 case EXPR_STRUCTURE
:
4745 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4759 /* Evaluate interface expression EXPR using MAPPING. Store the result
4763 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4764 gfc_se
* se
, gfc_expr
* expr
)
4766 expr
= gfc_copy_expr (expr
);
4767 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4768 gfc_conv_expr (se
, expr
);
4769 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4770 gfc_free_expr (expr
);
4774 /* Returns a reference to a temporary array into which a component of
4775 an actual argument derived type array is copied and then returned
4776 after the function call. */
4778 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4779 sym_intent intent
, bool formal_ptr
)
4787 gfc_array_info
*info
;
4797 gfc_init_se (&lse
, NULL
);
4798 gfc_init_se (&rse
, NULL
);
4800 /* Walk the argument expression. */
4801 rss
= gfc_walk_expr (expr
);
4803 gcc_assert (rss
!= gfc_ss_terminator
);
4805 /* Initialize the scalarizer. */
4806 gfc_init_loopinfo (&loop
);
4807 gfc_add_ss_to_loop (&loop
, rss
);
4809 /* Calculate the bounds of the scalarization. */
4810 gfc_conv_ss_startstride (&loop
);
4812 /* Build an ss for the temporary. */
4813 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4814 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4816 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4817 if (GFC_ARRAY_TYPE_P (base_type
)
4818 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4819 base_type
= gfc_get_element_type (base_type
);
4821 if (expr
->ts
.type
== BT_CLASS
)
4822 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4824 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4825 ? expr
->ts
.u
.cl
->backend_decl
4829 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4831 /* Associate the SS with the loop. */
4832 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4834 /* Setup the scalarizing loops. */
4835 gfc_conv_loop_setup (&loop
, &expr
->where
);
4837 /* Pass the temporary descriptor back to the caller. */
4838 info
= &loop
.temp_ss
->info
->data
.array
;
4839 parmse
->expr
= info
->descriptor
;
4841 /* Setup the gfc_se structures. */
4842 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4843 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4846 lse
.ss
= loop
.temp_ss
;
4847 gfc_mark_ss_chain_used (rss
, 1);
4848 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4850 /* Start the scalarized loop body. */
4851 gfc_start_scalarized_body (&loop
, &body
);
4853 /* Translate the expression. */
4854 gfc_conv_expr (&rse
, expr
);
4856 /* Reset the offset for the function call since the loop
4857 is zero based on the data pointer. Note that the temp
4858 comes first in the loop chain since it is added second. */
4859 if (gfc_is_class_array_function (expr
))
4861 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4862 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4863 gfc_index_zero_node
);
4866 gfc_conv_tmp_array_ref (&lse
);
4868 if (intent
!= INTENT_OUT
)
4870 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4871 gfc_add_expr_to_block (&body
, tmp
);
4872 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4873 gfc_trans_scalarizing_loops (&loop
, &body
);
4877 /* Make sure that the temporary declaration survives by merging
4878 all the loop declarations into the current context. */
4879 for (n
= 0; n
< loop
.dimen
; n
++)
4881 gfc_merge_block_scope (&body
);
4882 body
= loop
.code
[loop
.order
[n
]];
4884 gfc_merge_block_scope (&body
);
4887 /* Add the post block after the second loop, so that any
4888 freeing of allocated memory is done at the right time. */
4889 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4891 /**********Copy the temporary back again.*********/
4893 gfc_init_se (&lse
, NULL
);
4894 gfc_init_se (&rse
, NULL
);
4896 /* Walk the argument expression. */
4897 lss
= gfc_walk_expr (expr
);
4898 rse
.ss
= loop
.temp_ss
;
4901 /* Initialize the scalarizer. */
4902 gfc_init_loopinfo (&loop2
);
4903 gfc_add_ss_to_loop (&loop2
, lss
);
4905 dimen
= rse
.ss
->dimen
;
4907 /* Skip the write-out loop for this case. */
4908 if (gfc_is_class_array_function (expr
))
4909 goto class_array_fcn
;
4911 /* Calculate the bounds of the scalarization. */
4912 gfc_conv_ss_startstride (&loop2
);
4914 /* Setup the scalarizing loops. */
4915 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4917 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4918 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4920 gfc_mark_ss_chain_used (lss
, 1);
4921 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4923 /* Declare the variable to hold the temporary offset and start the
4924 scalarized loop body. */
4925 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4926 gfc_start_scalarized_body (&loop2
, &body
);
4928 /* Build the offsets for the temporary from the loop variables. The
4929 temporary array has lbounds of zero and strides of one in all
4930 dimensions, so this is very simple. The offset is only computed
4931 outside the innermost loop, so the overall transfer could be
4932 optimized further. */
4933 info
= &rse
.ss
->info
->data
.array
;
4935 tmp_index
= gfc_index_zero_node
;
4936 for (n
= dimen
- 1; n
> 0; n
--)
4939 tmp
= rse
.loop
->loopvar
[n
];
4940 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4941 tmp
, rse
.loop
->from
[n
]);
4942 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4945 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4946 gfc_array_index_type
,
4947 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4948 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4949 gfc_array_index_type
,
4950 tmp_str
, gfc_index_one_node
);
4952 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4953 gfc_array_index_type
, tmp
, tmp_str
);
4956 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4957 gfc_array_index_type
,
4958 tmp_index
, rse
.loop
->from
[0]);
4959 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4961 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4962 gfc_array_index_type
,
4963 rse
.loop
->loopvar
[0], offset
);
4965 /* Now use the offset for the reference. */
4966 tmp
= build_fold_indirect_ref_loc (input_location
,
4968 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4970 if (expr
->ts
.type
== BT_CHARACTER
)
4971 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4973 gfc_conv_expr (&lse
, expr
);
4975 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4977 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4978 gfc_add_expr_to_block (&body
, tmp
);
4980 /* Generate the copying loops. */
4981 gfc_trans_scalarizing_loops (&loop2
, &body
);
4983 /* Wrap the whole thing up by adding the second loop to the post-block
4984 and following it by the post-block of the first loop. In this way,
4985 if the temporary needs freeing, it is done after use! */
4986 if (intent
!= INTENT_IN
)
4988 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4989 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4994 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4996 gfc_cleanup_loop (&loop
);
4997 gfc_cleanup_loop (&loop2
);
4999 /* Pass the string length to the argument expression. */
5000 if (expr
->ts
.type
== BT_CHARACTER
)
5001 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5003 /* Determine the offset for pointer formal arguments and set the
5007 size
= gfc_index_one_node
;
5008 offset
= gfc_index_zero_node
;
5009 for (n
= 0; n
< dimen
; n
++)
5011 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
5013 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5014 gfc_array_index_type
, tmp
,
5015 gfc_index_one_node
);
5016 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
5020 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
5023 gfc_index_one_node
);
5024 size
= gfc_evaluate_now (size
, &parmse
->pre
);
5025 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5026 gfc_array_index_type
,
5028 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
5029 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5030 gfc_array_index_type
,
5031 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
5032 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5033 gfc_array_index_type
,
5034 tmp
, gfc_index_one_node
);
5035 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5036 gfc_array_index_type
, size
, tmp
);
5039 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
5043 /* We want either the address for the data or the address of the descriptor,
5044 depending on the mode of passing array arguments. */
5046 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
5048 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5054 /* Generate the code for argument list functions. */
5057 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5059 /* Pass by value for g77 %VAL(arg), pass the address
5060 indirectly for %LOC, else by reference. Thus %REF
5061 is a "do-nothing" and %LOC is the same as an F95
5063 if (strcmp (name
, "%VAL") == 0)
5064 gfc_conv_expr (se
, expr
);
5065 else if (strcmp (name
, "%LOC") == 0)
5067 gfc_conv_expr_reference (se
, expr
);
5068 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5070 else if (strcmp (name
, "%REF") == 0)
5071 gfc_conv_expr_reference (se
, expr
);
5073 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5077 /* This function tells whether the middle-end representation of the expression
5078 E given as input may point to data otherwise accessible through a variable
5080 It is assumed that the only expressions that may alias are variables,
5081 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5083 This function is used to decide whether freeing an expression's allocatable
5084 components is safe or should be avoided.
5086 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5087 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5088 is necessary because for array constructors, aliasing depends on how
5090 - If E is an array constructor used as argument to an elemental procedure,
5091 the array, which is generated through shallow copy by the scalarizer,
5092 is used directly and can alias the expressions it was copied from.
5093 - If E is an array constructor used as argument to a non-elemental
5094 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5095 the array as in the previous case, but then that array is used
5096 to initialize a new descriptor through deep copy. There is no alias
5097 possible in that case.
5098 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5102 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5106 if (e
->expr_type
== EXPR_VARIABLE
)
5108 else if (e
->expr_type
== EXPR_FUNCTION
)
5110 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5112 if (proc_ifc
->result
!= NULL
5113 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5114 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5115 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5116 || proc_ifc
->result
->attr
.pointer
))
5121 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5124 for (c
= gfc_constructor_first (e
->value
.constructor
);
5125 c
; c
= gfc_constructor_next (c
))
5127 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5134 /* A helper function to set the dtype for unallocated or unassociated
5138 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5146 /* TODO Figure out how to handle optional dummies. */
5147 if (e
&& e
->expr_type
== EXPR_VARIABLE
5148 && e
->symtree
->n
.sym
->attr
.optional
)
5151 desc
= parmse
->expr
;
5152 if (desc
== NULL_TREE
)
5155 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5156 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5158 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5161 gfc_init_block (&block
);
5162 tmp
= gfc_conv_descriptor_data_get (desc
);
5163 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5164 logical_type_node
, tmp
,
5165 build_int_cst (TREE_TYPE (tmp
), 0));
5166 tmp
= gfc_conv_descriptor_dtype (desc
);
5167 type
= gfc_get_element_type (TREE_TYPE (desc
));
5168 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5169 TREE_TYPE (tmp
), tmp
,
5170 gfc_get_dtype_rank_type (e
->rank
, type
));
5171 gfc_add_expr_to_block (&block
, tmp
);
5172 cond
= build3_v (COND_EXPR
, cond
,
5173 gfc_finish_block (&block
),
5174 build_empty_stmt (input_location
));
5175 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5180 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5181 ISO_Fortran_binding array descriptors. */
5184 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5194 symbol_attribute attr
= gfc_expr_attr (e
);
5196 /* If this is a full array or a scalar, the allocatable and pointer
5197 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5199 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
5203 else if (attr
.allocatable
)
5207 /* If the formal argument is assumed shape and neither a pointer nor
5208 allocatable, it is unconditionally CFI_attribute_other. */
5209 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
5210 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)
5213 cfi_attribute
= attribute
;
5217 parmse
->force_no_tmp
= 1;
5218 if (fsym
->attr
.contiguous
5219 && !gfc_is_simply_contiguous (e
, false, true))
5220 gfc_conv_subref_array_arg (parmse
, e
, false, fsym
->attr
.intent
,
5221 fsym
->attr
.pointer
);
5223 gfc_conv_expr_descriptor (parmse
, e
);
5225 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5226 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5229 bool is_artificial
= (INDIRECT_REF_P (parmse
->expr
)
5230 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse
->expr
, 0))
5231 : DECL_ARTIFICIAL (parmse
->expr
));
5233 /* Unallocated allocatable arrays and unassociated pointer arrays
5234 need their dtype setting if they are argument associated with
5235 assumed rank dummies. */
5236 if (fsym
&& fsym
->as
5237 && (gfc_expr_attr (e
).pointer
5238 || gfc_expr_attr (e
).allocatable
))
5239 set_dtype_for_unallocated (parmse
, e
);
5241 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5242 the expression type is different from the descriptor type, then
5243 the offset must be found (eg. to a component ref or substring)
5244 and the dtype updated. Assumed type entities are only allowed
5245 to be dummies in Fortran. They therefore lack the decl specific
5246 appendiges and so must be treated differently from other fortran
5247 entities passed to CFI descriptors in the interface decl. */
5248 type
= e
->ts
.type
!= BT_ASSUMED
? gfc_typenode_for_spec (&e
->ts
) :
5251 if (type
&& is_artificial
5252 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
5254 /* Obtain the offset to the data. */
5255 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
5256 gfc_index_zero_node
, true, e
);
5258 /* Update the dtype. */
5259 gfc_add_modify (&parmse
->pre
,
5260 gfc_conv_descriptor_dtype (parmse
->expr
),
5261 gfc_get_dtype_rank_type (e
->rank
, type
));
5263 else if (type
== NULL_TREE
|| (!is_subref_array (e
) && !is_artificial
))
5265 /* Make sure that the span is set for expressions where it
5266 might not have been done already. */
5267 tmp
= gfc_conv_descriptor_elem_len (parmse
->expr
);
5268 tmp
= fold_convert (gfc_array_index_type
, tmp
);
5269 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
5274 gfc_conv_expr (parmse
, e
);
5276 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
5277 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
5280 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
5281 parmse
->expr
, attr
);
5284 /* Set the CFI attribute field through a temporary value for the
5286 desc_attr
= gfc_conv_descriptor_attribute (parmse
->expr
);
5287 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5288 void_type_node
, desc_attr
,
5289 build_int_cst (TREE_TYPE (desc_attr
), cfi_attribute
));
5290 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5292 /* Now pass the gfc_descriptor by reference. */
5293 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5295 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5296 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5297 gfc_desc_ptr
= parmse
->expr
;
5298 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
5299 gfc_add_modify (&parmse
->pre
, cfi_desc_ptr
, null_pointer_node
);
5301 /* Allocate the CFI descriptor itself and fill the fields. */
5302 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
5303 tmp
= build_call_expr_loc (input_location
,
5304 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
5305 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5307 /* Now set the gfc descriptor attribute. */
5308 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5309 void_type_node
, desc_attr
,
5310 build_int_cst (TREE_TYPE (desc_attr
), attribute
));
5311 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5313 /* The CFI descriptor is passed to the bind_C procedure. */
5314 parmse
->expr
= cfi_desc_ptr
;
5316 /* Free the CFI descriptor. */
5317 tmp
= gfc_call_free (cfi_desc_ptr
);
5318 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5320 /* Transfer values back to gfc descriptor. */
5321 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5322 tmp
= build_call_expr_loc (input_location
,
5323 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
5324 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
5326 /* Deal with an optional dummy being passed to an optional formal arg
5327 by finishing the pre and post blocks and making their execution
5328 conditional on the dummy being present. */
5329 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5330 && e
->symtree
->n
.sym
->attr
.optional
)
5332 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5333 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
5335 build_int_cst (pvoid_type_node
, 0));
5336 tmp
= build3_v (COND_EXPR
, cond
,
5337 gfc_finish_block (&parmse
->pre
), tmp
);
5338 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5339 tmp
= build3_v (COND_EXPR
, cond
,
5340 gfc_finish_block (&parmse
->post
),
5341 build_empty_stmt (input_location
));
5342 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5347 /* Generate code for a procedure call. Note can return se->post != NULL.
5348 If se->direct_byref is set then se->expr contains the return parameter.
5349 Return nonzero, if the call has alternate specifiers.
5350 'expr' is only needed for procedure pointer components. */
5353 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5354 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5355 vec
<tree
, va_gc
> *append_args
)
5357 gfc_interface_mapping mapping
;
5358 vec
<tree
, va_gc
> *arglist
;
5359 vec
<tree
, va_gc
> *retargs
;
5363 gfc_array_info
*info
;
5370 vec
<tree
, va_gc
> *stringargs
;
5371 vec
<tree
, va_gc
> *optionalargs
;
5373 gfc_formal_arglist
*formal
;
5374 gfc_actual_arglist
*arg
;
5375 int has_alternate_specifier
= 0;
5376 bool need_interface_mapping
;
5384 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5385 gfc_component
*comp
= NULL
;
5392 optionalargs
= NULL
;
5397 comp
= gfc_get_proc_ptr_comp (expr
);
5399 bool elemental_proc
= (comp
5400 && comp
->ts
.interface
5401 && comp
->ts
.interface
->attr
.elemental
)
5402 || (comp
&& comp
->attr
.elemental
)
5403 || sym
->attr
.elemental
;
5407 if (!elemental_proc
)
5409 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5410 if (se
->ss
->info
->useflags
)
5412 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5413 && sym
->result
->attr
.dimension
)
5414 || (comp
&& comp
->attr
.dimension
)
5415 || gfc_is_class_array_function (expr
));
5416 gcc_assert (se
->loop
!= NULL
);
5417 /* Access the previously obtained result. */
5418 gfc_conv_tmp_array_ref (se
);
5422 info
= &se
->ss
->info
->data
.array
;
5427 gfc_init_block (&post
);
5428 gfc_init_interface_mapping (&mapping
);
5431 formal
= gfc_sym_get_dummy_args (sym
);
5432 need_interface_mapping
= sym
->attr
.dimension
||
5433 (sym
->ts
.type
== BT_CHARACTER
5434 && sym
->ts
.u
.cl
->length
5435 && sym
->ts
.u
.cl
->length
->expr_type
5440 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5441 need_interface_mapping
= comp
->attr
.dimension
||
5442 (comp
->ts
.type
== BT_CHARACTER
5443 && comp
->ts
.u
.cl
->length
5444 && comp
->ts
.u
.cl
->length
->expr_type
5448 base_object
= NULL_TREE
;
5449 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5450 is the third and fourth argument to such a function call a value
5451 denoting the number of elements to copy (i.e., most of the time the
5452 length of a deferred length string). */
5453 ulim_copy
= (formal
== NULL
)
5454 && UNLIMITED_POLY (sym
)
5455 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5457 /* Evaluate the arguments. */
5458 for (arg
= args
, argc
= 0; arg
!= NULL
;
5459 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5461 bool finalized
= false;
5462 bool non_unity_length_string
= false;
5465 fsym
= formal
? formal
->sym
: NULL
;
5466 parm_kind
= MISSING
;
5468 if (fsym
&& fsym
->ts
.type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
5469 && (!fsym
->ts
.u
.cl
->length
5470 || fsym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5471 || mpz_cmp_si (fsym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0))
5472 non_unity_length_string
= true;
5474 /* If the procedure requires an explicit interface, the actual
5475 argument is passed according to the corresponding formal
5476 argument. If the corresponding formal argument is a POINTER,
5477 ALLOCATABLE or assumed shape, we do not use g77's calling
5478 convention, and pass the address of the array descriptor
5479 instead. Otherwise we use g77's calling convention, in other words
5480 pass the array data pointer without descriptor. */
5481 bool nodesc_arg
= fsym
!= NULL
5482 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5484 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5485 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5487 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5489 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5491 /* Class array expressions are sometimes coming completely unadorned
5492 with either arrayspec or _data component. Correct that here.
5493 OOP-TODO: Move this to the frontend. */
5494 if (e
&& e
->expr_type
== EXPR_VARIABLE
5496 && e
->ts
.type
== BT_CLASS
5497 && (CLASS_DATA (e
)->attr
.codimension
5498 || CLASS_DATA (e
)->attr
.dimension
))
5500 gfc_typespec temp_ts
= e
->ts
;
5501 gfc_add_class_array_ref (e
);
5507 if (se
->ignore_optional
)
5509 /* Some intrinsics have already been resolved to the correct
5513 else if (arg
->label
)
5515 has_alternate_specifier
= 1;
5520 gfc_init_se (&parmse
, NULL
);
5522 /* For scalar arguments with VALUE attribute which are passed by
5523 value, pass "0" and a hidden argument gives the optional
5525 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5526 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5527 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5529 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5531 vec_safe_push (optionalargs
, boolean_false_node
);
5535 /* Pass a NULL pointer for an absent arg. */
5536 parmse
.expr
= null_pointer_node
;
5537 if (arg
->missing_arg_type
== BT_CHARACTER
)
5538 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5543 else if (arg
->expr
->expr_type
== EXPR_NULL
5544 && fsym
&& !fsym
->attr
.pointer
5545 && (fsym
->ts
.type
!= BT_CLASS
5546 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5548 /* Pass a NULL pointer to denote an absent arg. */
5549 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5550 && (fsym
->ts
.type
!= BT_CLASS
5551 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5552 gfc_init_se (&parmse
, NULL
);
5553 parmse
.expr
= null_pointer_node
;
5554 if (arg
->missing_arg_type
== BT_CHARACTER
)
5555 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5557 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5558 && e
->ts
.type
== BT_DERIVED
)
5560 /* The derived type needs to be converted to a temporary
5562 gfc_init_se (&parmse
, se
);
5563 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5565 && e
->expr_type
== EXPR_VARIABLE
5566 && e
->symtree
->n
.sym
->attr
.optional
,
5567 CLASS_DATA (fsym
)->attr
.class_pointer
5568 || CLASS_DATA (fsym
)->attr
.allocatable
);
5570 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
5571 && gfc_expr_attr (e
).flavor
!= FL_PROCEDURE
)
5573 /* The intrinsic type needs to be converted to a temporary
5574 CLASS object for the unlimited polymorphic formal. */
5575 gfc_find_vtab (&e
->ts
);
5576 gfc_init_se (&parmse
, se
);
5577 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5580 else if (se
->ss
&& se
->ss
->info
->useflags
)
5586 /* An elemental function inside a scalarized loop. */
5587 gfc_init_se (&parmse
, se
);
5588 parm_kind
= ELEMENTAL
;
5590 /* When no fsym is present, ulim_copy is set and this is a third or
5591 fourth argument, use call-by-value instead of by reference to
5592 hand the length properties to the copy routine (i.e., most of the
5593 time this will be a call to a __copy_character_* routine where the
5594 third and fourth arguments are the lengths of a deferred length
5596 if ((fsym
&& fsym
->attr
.value
)
5597 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5598 gfc_conv_expr (&parmse
, e
);
5600 gfc_conv_expr_reference (&parmse
, e
);
5602 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5603 && e
->expr_type
== EXPR_FUNCTION
)
5604 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5607 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5608 && gfc_is_class_container_ref (e
))
5610 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5612 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5613 && e
->symtree
->n
.sym
->attr
.optional
)
5615 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5616 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5617 TREE_TYPE (parmse
.expr
),
5619 fold_convert (TREE_TYPE (parmse
.expr
),
5620 null_pointer_node
));
5624 /* If we are passing an absent array as optional dummy to an
5625 elemental procedure, make sure that we pass NULL when the data
5626 pointer is NULL. We need this extra conditional because of
5627 scalarization which passes arrays elements to the procedure,
5628 ignoring the fact that the array can be absent/unallocated/... */
5629 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5631 tree descriptor_data
;
5633 descriptor_data
= ss
->info
->data
.array
.data
;
5634 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5636 fold_convert (TREE_TYPE (descriptor_data
),
5637 null_pointer_node
));
5639 = fold_build3_loc (input_location
, COND_EXPR
,
5640 TREE_TYPE (parmse
.expr
),
5641 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5642 fold_convert (TREE_TYPE (parmse
.expr
),
5647 /* The scalarizer does not repackage the reference to a class
5648 array - instead it returns a pointer to the data element. */
5649 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5650 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5651 fsym
->attr
.intent
!= INTENT_IN
5652 && (CLASS_DATA (fsym
)->attr
.class_pointer
5653 || CLASS_DATA (fsym
)->attr
.allocatable
),
5655 && e
->expr_type
== EXPR_VARIABLE
5656 && e
->symtree
->n
.sym
->attr
.optional
,
5657 CLASS_DATA (fsym
)->attr
.class_pointer
5658 || CLASS_DATA (fsym
)->attr
.allocatable
);
5665 gfc_init_se (&parmse
, NULL
);
5667 /* Check whether the expression is a scalar or not; we cannot use
5668 e->rank as it can be nonzero for functions arguments. */
5669 argss
= gfc_walk_expr (e
);
5670 scalar
= argss
== gfc_ss_terminator
;
5672 gfc_free_ss_chain (argss
);
5674 /* Special handling for passing scalar polymorphic coarrays;
5675 otherwise one passes "class->_data.data" instead of "&class". */
5676 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5677 && fsym
&& fsym
->ts
.type
== BT_CLASS
5678 && CLASS_DATA (fsym
)->attr
.codimension
5679 && !CLASS_DATA (fsym
)->attr
.dimension
)
5681 gfc_add_class_array_ref (e
);
5682 parmse
.want_coarray
= 1;
5686 /* A scalar or transformational function. */
5689 if (e
->expr_type
== EXPR_VARIABLE
5690 && e
->symtree
->n
.sym
->attr
.cray_pointee
5691 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5693 /* The Cray pointer needs to be converted to a pointer to
5694 a type given by the expression. */
5695 gfc_conv_expr (&parmse
, e
);
5696 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5697 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5698 parmse
.expr
= convert (type
, tmp
);
5701 else if (sym
->attr
.is_bind_c
&& e
5702 && (is_CFI_desc (fsym
, NULL
)
5703 || non_unity_length_string
))
5704 /* Implement F2018, C.12.6.1: paragraph (2). */
5705 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5707 else if (fsym
&& fsym
->attr
.value
)
5709 if (fsym
->ts
.type
== BT_CHARACTER
5710 && fsym
->ts
.is_c_interop
5711 && fsym
->ns
->proc_name
!= NULL
5712 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5715 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5716 if (parmse
.expr
== NULL
)
5717 gfc_conv_expr (&parmse
, e
);
5721 gfc_conv_expr (&parmse
, e
);
5722 if (fsym
->attr
.optional
5723 && fsym
->ts
.type
!= BT_CLASS
5724 && fsym
->ts
.type
!= BT_DERIVED
)
5726 if (e
->expr_type
!= EXPR_VARIABLE
5727 || !e
->symtree
->n
.sym
->attr
.optional
5729 vec_safe_push (optionalargs
, boolean_true_node
);
5732 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5733 if (!e
->symtree
->n
.sym
->attr
.value
)
5735 = fold_build3_loc (input_location
, COND_EXPR
,
5736 TREE_TYPE (parmse
.expr
),
5738 fold_convert (TREE_TYPE (parmse
.expr
),
5739 integer_zero_node
));
5741 vec_safe_push (optionalargs
, tmp
);
5747 else if (arg
->name
&& arg
->name
[0] == '%')
5748 /* Argument list functions %VAL, %LOC and %REF are signalled
5749 through arg->name. */
5750 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5751 else if ((e
->expr_type
== EXPR_FUNCTION
)
5752 && ((e
->value
.function
.esym
5753 && e
->value
.function
.esym
->result
->attr
.pointer
)
5754 || (!e
->value
.function
.esym
5755 && e
->symtree
->n
.sym
->attr
.pointer
))
5756 && fsym
&& fsym
->attr
.target
)
5758 gfc_conv_expr (&parmse
, e
);
5759 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5762 else if (e
->expr_type
== EXPR_FUNCTION
5763 && e
->symtree
->n
.sym
->result
5764 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5765 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5767 /* Functions returning procedure pointers. */
5768 gfc_conv_expr (&parmse
, e
);
5769 if (fsym
&& fsym
->attr
.proc_pointer
)
5770 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5775 if (e
->ts
.type
== BT_CLASS
&& fsym
5776 && fsym
->ts
.type
== BT_CLASS
5777 && (!CLASS_DATA (fsym
)->as
5778 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5779 && CLASS_DATA (e
)->attr
.codimension
)
5781 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5782 gcc_assert (!CLASS_DATA (fsym
)->as
);
5783 gfc_add_class_array_ref (e
);
5784 parmse
.want_coarray
= 1;
5785 gfc_conv_expr_reference (&parmse
, e
);
5786 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5788 && e
->expr_type
== EXPR_VARIABLE
);
5790 else if (e
->ts
.type
== BT_CLASS
&& fsym
5791 && fsym
->ts
.type
== BT_CLASS
5792 && !CLASS_DATA (fsym
)->as
5793 && !CLASS_DATA (e
)->as
5794 && strcmp (fsym
->ts
.u
.derived
->name
,
5795 e
->ts
.u
.derived
->name
))
5797 type
= gfc_typenode_for_spec (&fsym
->ts
);
5798 var
= gfc_create_var (type
, fsym
->name
);
5799 gfc_conv_expr (&parmse
, e
);
5800 if (fsym
->attr
.optional
5801 && e
->expr_type
== EXPR_VARIABLE
5802 && e
->symtree
->n
.sym
->attr
.optional
)
5806 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5807 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5808 logical_type_node
, tmp
,
5809 fold_convert (TREE_TYPE (tmp
),
5810 null_pointer_node
));
5811 gfc_start_block (&block
);
5812 gfc_add_modify (&block
, var
,
5813 fold_build1_loc (input_location
,
5815 type
, parmse
.expr
));
5816 gfc_add_expr_to_block (&parmse
.pre
,
5817 fold_build3_loc (input_location
,
5818 COND_EXPR
, void_type_node
,
5819 cond
, gfc_finish_block (&block
),
5820 build_empty_stmt (input_location
)));
5821 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5822 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5823 TREE_TYPE (parmse
.expr
),
5825 fold_convert (TREE_TYPE (parmse
.expr
),
5826 null_pointer_node
));
5830 /* Since the internal representation of unlimited
5831 polymorphic expressions includes an extra field
5832 that other class objects do not, a cast to the
5833 formal type does not work. */
5834 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5838 /* Set the _data field. */
5839 tmp
= gfc_class_data_get (var
);
5840 efield
= fold_convert (TREE_TYPE (tmp
),
5841 gfc_class_data_get (parmse
.expr
));
5842 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5844 /* Set the _vptr field. */
5845 tmp
= gfc_class_vptr_get (var
);
5846 efield
= fold_convert (TREE_TYPE (tmp
),
5847 gfc_class_vptr_get (parmse
.expr
));
5848 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5850 /* Set the _len field. */
5851 tmp
= gfc_class_len_get (var
);
5852 gfc_add_modify (&parmse
.pre
, tmp
,
5853 build_int_cst (TREE_TYPE (tmp
), 0));
5857 tmp
= fold_build1_loc (input_location
,
5860 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5863 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5869 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5870 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5871 && e
->symtree
&& e
->symtree
->n
.sym
5872 && !e
->symtree
->n
.sym
->attr
.dimension
5873 && !e
->symtree
->n
.sym
->attr
.pointer
5874 && !e
->symtree
->n
.sym
->attr
.allocatable
5876 && !e
->symtree
->n
.sym
->attr
.dummy
5877 /* FIXME - PR 87395 and PR 41453 */
5878 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5879 && !e
->symtree
->n
.sym
->attr
.associate_var
5880 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5881 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5883 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5885 /* Catch base objects that are not variables. */
5886 if (e
->ts
.type
== BT_CLASS
5887 && e
->expr_type
!= EXPR_VARIABLE
5888 && expr
&& e
== expr
->base_expr
)
5889 base_object
= build_fold_indirect_ref_loc (input_location
,
5892 /* A class array element needs converting back to be a
5893 class object, if the formal argument is a class object. */
5894 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5895 && e
->ts
.type
== BT_CLASS
5896 && ((CLASS_DATA (fsym
)->as
5897 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5898 || CLASS_DATA (e
)->attr
.dimension
))
5899 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5900 fsym
->attr
.intent
!= INTENT_IN
5901 && (CLASS_DATA (fsym
)->attr
.class_pointer
5902 || CLASS_DATA (fsym
)->attr
.allocatable
),
5904 && e
->expr_type
== EXPR_VARIABLE
5905 && e
->symtree
->n
.sym
->attr
.optional
,
5906 CLASS_DATA (fsym
)->attr
.class_pointer
5907 || CLASS_DATA (fsym
)->attr
.allocatable
);
5909 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5910 allocated on entry, it must be deallocated. */
5911 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5912 && (fsym
->attr
.allocatable
5913 || (fsym
->ts
.type
== BT_CLASS
5914 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5919 gfc_init_block (&block
);
5921 if (e
->ts
.type
== BT_CLASS
)
5922 ptr
= gfc_class_data_get (ptr
);
5924 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5927 gfc_add_expr_to_block (&block
, tmp
);
5928 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5929 void_type_node
, ptr
,
5931 gfc_add_expr_to_block (&block
, tmp
);
5933 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5935 gfc_add_modify (&block
, ptr
,
5936 fold_convert (TREE_TYPE (ptr
),
5937 null_pointer_node
));
5938 gfc_add_expr_to_block (&block
, tmp
);
5940 else if (fsym
->ts
.type
== BT_CLASS
)
5943 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5944 tmp
= gfc_get_symbol_decl (vtab
);
5945 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5946 ptr
= gfc_class_vptr_get (parmse
.expr
);
5947 gfc_add_modify (&block
, ptr
,
5948 fold_convert (TREE_TYPE (ptr
), tmp
));
5949 gfc_add_expr_to_block (&block
, tmp
);
5952 if (fsym
->attr
.optional
5953 && e
->expr_type
== EXPR_VARIABLE
5954 && e
->symtree
->n
.sym
->attr
.optional
)
5956 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5958 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5959 gfc_finish_block (&block
),
5960 build_empty_stmt (input_location
));
5963 tmp
= gfc_finish_block (&block
);
5965 gfc_add_expr_to_block (&se
->pre
, tmp
);
5968 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5969 || fsym
->ts
.type
== BT_ASSUMED
)
5970 && e
->ts
.type
== BT_CLASS
5971 && !CLASS_DATA (e
)->attr
.dimension
5972 && !CLASS_DATA (e
)->attr
.codimension
)
5974 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5975 /* The result is a class temporary, whose _data component
5976 must be freed to avoid a memory leak. */
5977 if (e
->expr_type
== EXPR_FUNCTION
5978 && CLASS_DATA (e
)->attr
.allocatable
)
5984 /* Borrow the function symbol to make a call to
5985 gfc_add_finalizer_call and then restore it. */
5986 tmp
= e
->symtree
->n
.sym
->backend_decl
;
5987 e
->symtree
->n
.sym
->backend_decl
5988 = TREE_OPERAND (parmse
.expr
, 0);
5989 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5990 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
5991 finalized
= gfc_add_finalizer_call (&parmse
.post
,
5993 gfc_free_expr (var
);
5994 e
->symtree
->n
.sym
->backend_decl
= tmp
;
5995 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5997 /* Then free the class _data. */
5998 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
5999 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6002 tmp
= build3_v (COND_EXPR
, tmp
,
6003 gfc_call_free (parmse
.expr
),
6004 build_empty_stmt (input_location
));
6005 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6006 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6010 /* Wrap scalar variable in a descriptor. We need to convert
6011 the address of a pointer back to the pointer itself before,
6012 we can assign it to the data field. */
6014 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6015 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6018 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6019 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6020 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6022 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6025 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6026 && ((fsym
->attr
.pointer
6027 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6028 || (fsym
->attr
.proc_pointer
6029 && !(e
->expr_type
== EXPR_VARIABLE
6030 && e
->symtree
->n
.sym
->attr
.dummy
))
6031 || (fsym
->attr
.proc_pointer
6032 && e
->expr_type
== EXPR_VARIABLE
6033 && gfc_is_proc_ptr_comp (e
))
6034 || (fsym
->attr
.allocatable
6035 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6037 /* Scalar pointer dummy args require an extra level of
6038 indirection. The null pointer already contains
6039 this level of indirection. */
6040 parm_kind
= SCALAR_POINTER
;
6041 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6045 else if (e
->ts
.type
== BT_CLASS
6046 && fsym
&& fsym
->ts
.type
== BT_CLASS
6047 && (CLASS_DATA (fsym
)->attr
.dimension
6048 || CLASS_DATA (fsym
)->attr
.codimension
))
6050 /* Pass a class array. */
6051 parmse
.use_offset
= 1;
6052 gfc_conv_expr_descriptor (&parmse
, e
);
6054 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6055 allocated on entry, it must be deallocated. */
6056 if (fsym
->attr
.intent
== INTENT_OUT
6057 && CLASS_DATA (fsym
)->attr
.allocatable
)
6062 gfc_init_block (&block
);
6064 ptr
= gfc_class_data_get (ptr
);
6066 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6067 NULL_TREE
, NULL_TREE
,
6069 GFC_CAF_COARRAY_NOCOARRAY
);
6070 gfc_add_expr_to_block (&block
, tmp
);
6071 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6072 void_type_node
, ptr
,
6074 gfc_add_expr_to_block (&block
, tmp
);
6075 gfc_reset_vptr (&block
, e
);
6077 if (fsym
->attr
.optional
6078 && e
->expr_type
== EXPR_VARIABLE
6080 || (e
->ref
->type
== REF_ARRAY
6081 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6082 && e
->symtree
->n
.sym
->attr
.optional
)
6084 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6086 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6087 gfc_finish_block (&block
),
6088 build_empty_stmt (input_location
));
6091 tmp
= gfc_finish_block (&block
);
6093 gfc_add_expr_to_block (&se
->pre
, tmp
);
6096 /* The conversion does not repackage the reference to a class
6097 array - _data descriptor. */
6098 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6099 fsym
->attr
.intent
!= INTENT_IN
6100 && (CLASS_DATA (fsym
)->attr
.class_pointer
6101 || CLASS_DATA (fsym
)->attr
.allocatable
),
6103 && e
->expr_type
== EXPR_VARIABLE
6104 && e
->symtree
->n
.sym
->attr
.optional
,
6105 CLASS_DATA (fsym
)->attr
.class_pointer
6106 || CLASS_DATA (fsym
)->attr
.allocatable
);
6110 /* If the argument is a function call that may not create
6111 a temporary for the result, we have to check that we
6112 can do it, i.e. that there is no alias between this
6113 argument and another one. */
6114 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6120 intent
= fsym
->attr
.intent
;
6122 intent
= INTENT_UNKNOWN
;
6124 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6126 parmse
.force_tmp
= 1;
6128 iarg
= e
->value
.function
.actual
->expr
;
6130 /* Temporary needed if aliasing due to host association. */
6131 if (sym
->attr
.contained
6133 && !sym
->attr
.implicit_pure
6134 && !sym
->attr
.use_assoc
6135 && iarg
->expr_type
== EXPR_VARIABLE
6136 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6137 parmse
.force_tmp
= 1;
6139 /* Ditto within module. */
6140 if (sym
->attr
.use_assoc
6142 && !sym
->attr
.implicit_pure
6143 && iarg
->expr_type
== EXPR_VARIABLE
6144 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6145 parmse
.force_tmp
= 1;
6148 if (sym
->attr
.is_bind_c
&& e
6149 && (is_CFI_desc (fsym
, NULL
) || non_unity_length_string
))
6150 /* Implement F2018, C.12.6.1: paragraph (2). */
6151 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6153 else if (e
->expr_type
== EXPR_VARIABLE
6154 && is_subref_array (e
)
6155 && !(fsym
&& fsym
->attr
.pointer
))
6156 /* The actual argument is a component reference to an
6157 array of derived types. In this case, the argument
6158 is converted to a temporary, which is passed and then
6159 written back after the procedure call. */
6160 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6161 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6162 fsym
&& fsym
->attr
.pointer
);
6164 else if (gfc_is_class_array_ref (e
, NULL
)
6165 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6166 /* The actual argument is a component reference to an
6167 array of derived types. In this case, the argument
6168 is converted to a temporary, which is passed and then
6169 written back after the procedure call.
6170 OOP-TODO: Insert code so that if the dynamic type is
6171 the same as the declared type, copy-in/copy-out does
6173 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6175 fsym
->attr
.pointer
);
6177 else if (gfc_is_class_array_function (e
)
6178 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6179 /* See previous comment. For function actual argument,
6180 the write out is not needed so the intent is set as
6183 e
->must_finalize
= 1;
6184 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6185 INTENT_IN
, fsym
->attr
.pointer
);
6187 else if (fsym
&& fsym
->attr
.contiguous
6188 && !gfc_is_simply_contiguous (e
, false, true)
6189 && gfc_expr_is_variable (e
))
6191 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6193 fsym
->attr
.pointer
);
6196 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6199 /* Unallocated allocatable arrays and unassociated pointer arrays
6200 need their dtype setting if they are argument associated with
6201 assumed rank dummies. */
6202 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6203 && fsym
->as
->type
== AS_ASSUMED_RANK
)
6205 if (gfc_expr_attr (e
).pointer
6206 || gfc_expr_attr (e
).allocatable
)
6207 set_dtype_for_unallocated (&parmse
, e
);
6208 else if (e
->expr_type
== EXPR_VARIABLE
6209 && e
->symtree
->n
.sym
->attr
.dummy
6210 && e
->symtree
->n
.sym
->as
6211 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
6214 tmp
= build_fold_indirect_ref_loc (input_location
,
6216 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6217 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6218 gfc_rank_cst
[e
->rank
- 1],
6223 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6224 allocated on entry, it must be deallocated. */
6225 if (fsym
&& fsym
->attr
.allocatable
6226 && fsym
->attr
.intent
== INTENT_OUT
)
6228 if (fsym
->ts
.type
== BT_DERIVED
6229 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6231 // deallocate the components first
6232 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6233 parmse
.expr
, e
->rank
);
6234 if (tmp
!= NULL_TREE
)
6235 gfc_add_expr_to_block (&se
->pre
, tmp
);
6239 /* With bind(C), the actual argument is replaced by a bind-C
6240 descriptor; in this case, the data component arrives here,
6241 which shall not be dereferenced, but still freed and
6243 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6244 tmp
= build_fold_indirect_ref_loc (input_location
,
6246 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6247 tmp
= gfc_conv_descriptor_data_get (tmp
);
6248 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6249 NULL_TREE
, NULL_TREE
, true,
6251 GFC_CAF_COARRAY_NOCOARRAY
);
6252 if (fsym
->attr
.optional
6253 && e
->expr_type
== EXPR_VARIABLE
6254 && e
->symtree
->n
.sym
->attr
.optional
)
6255 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6257 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6258 tmp
, build_empty_stmt (input_location
));
6259 gfc_add_expr_to_block (&se
->pre
, tmp
);
6264 /* The case with fsym->attr.optional is that of a user subroutine
6265 with an interface indicating an optional argument. When we call
6266 an intrinsic subroutine, however, fsym is NULL, but we might still
6267 have an optional argument, so we proceed to the substitution
6269 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6271 /* If an optional argument is itself an optional dummy argument,
6272 check its presence and substitute a null if absent. This is
6273 only needed when passing an array to an elemental procedure
6274 as then array elements are accessed - or no NULL pointer is
6275 allowed and a "1" or "0" should be passed if not present.
6276 When passing a non-array-descriptor full array to a
6277 non-array-descriptor dummy, no check is needed. For
6278 array-descriptor actual to array-descriptor dummy, see
6279 PR 41911 for why a check has to be inserted.
6280 fsym == NULL is checked as intrinsics required the descriptor
6281 but do not always set fsym.
6282 Also, it is necessary to pass a NULL pointer to library routines
6283 which usually ignore optional arguments, so they can handle
6284 these themselves. */
6285 if (e
->expr_type
== EXPR_VARIABLE
6286 && e
->symtree
->n
.sym
->attr
.optional
6287 && (((e
->rank
!= 0 && elemental_proc
)
6288 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6292 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6293 || fsym
->as
->type
== AS_ASSUMED_RANK
6294 || fsym
->as
->type
== AS_DEFERRED
)))))
6295 || se
->ignore_optional
))
6296 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6297 e
->representation
.length
);
6302 /* Obtain the character length of an assumed character length
6303 length procedure from the typespec. */
6304 if (fsym
->ts
.type
== BT_CHARACTER
6305 && parmse
.string_length
== NULL_TREE
6306 && e
->ts
.type
== BT_PROCEDURE
6307 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6308 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6309 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6311 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6312 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6316 if (fsym
&& need_interface_mapping
&& e
)
6317 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6319 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6320 gfc_add_block_to_block (&post
, &parmse
.post
);
6322 /* Allocated allocatable components of derived types must be
6323 deallocated for non-variable scalars, array arguments to elemental
6324 procedures, and array arguments with descriptor to non-elemental
6325 procedures. As bounds information for descriptorless arrays is no
6326 longer available here, they are dealt with in trans-array.c
6327 (gfc_conv_array_parameter). */
6328 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
6329 && e
->ts
.u
.derived
->attr
.alloc_comp
6330 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
6331 && !expr_may_alias_variables (e
, elemental_proc
))
6334 /* It is known the e returns a structure type with at least one
6335 allocatable component. When e is a function, ensure that the
6336 function is called once only by using a temporary variable. */
6337 if (!DECL_P (parmse
.expr
))
6338 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
6339 parmse
.expr
, &se
->pre
);
6341 if (fsym
&& fsym
->attr
.value
)
6344 tmp
= build_fold_indirect_ref_loc (input_location
,
6347 parm_rank
= e
->rank
;
6355 case (SCALAR_POINTER
):
6356 tmp
= build_fold_indirect_ref_loc (input_location
,
6361 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
6363 /* The derived type is passed to gfc_deallocate_alloc_comp.
6364 Therefore, class actuals can be handled correctly but derived
6365 types passed to class formals need the _data component. */
6366 tmp
= gfc_class_data_get (tmp
);
6367 if (!CLASS_DATA (fsym
)->attr
.dimension
)
6368 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6371 if (e
->expr_type
== EXPR_OP
6372 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
6373 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
6376 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
6377 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
6379 gfc_add_expr_to_block (&se
->post
, local_tmp
);
6382 if (!finalized
&& !e
->must_finalize
)
6384 if ((e
->ts
.type
== BT_CLASS
6385 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
6386 || e
->ts
.type
== BT_DERIVED
)
6387 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6389 else if (e
->ts
.type
== BT_CLASS
)
6390 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6392 gfc_prepend_expr_to_block (&post
, tmp
);
6396 /* Add argument checking of passing an unallocated/NULL actual to
6397 a nonallocatable/nonpointer dummy. */
6399 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6401 symbol_attribute attr
;
6405 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6406 attr
= gfc_expr_attr (e
);
6408 goto end_pointer_check
;
6410 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6411 allocatable to an optional dummy, cf. 12.5.2.12. */
6412 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6413 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6414 goto end_pointer_check
;
6418 /* If the actual argument is an optional pointer/allocatable and
6419 the formal argument takes an nonpointer optional value,
6420 it is invalid to pass a non-present argument on, even
6421 though there is no technical reason for this in gfortran.
6422 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6423 tree present
, null_ptr
, type
;
6425 if (attr
.allocatable
6426 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6427 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6428 "allocated or not present",
6429 e
->symtree
->n
.sym
->name
);
6430 else if (attr
.pointer
6431 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6432 msg
= xasprintf ("Pointer actual argument '%s' is not "
6433 "associated or not present",
6434 e
->symtree
->n
.sym
->name
);
6435 else if (attr
.proc_pointer
6436 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6437 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6438 "associated or not present",
6439 e
->symtree
->n
.sym
->name
);
6441 goto end_pointer_check
;
6443 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6444 type
= TREE_TYPE (present
);
6445 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6446 logical_type_node
, present
,
6448 null_pointer_node
));
6449 type
= TREE_TYPE (parmse
.expr
);
6450 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6451 logical_type_node
, parmse
.expr
,
6453 null_pointer_node
));
6454 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6455 logical_type_node
, present
, null_ptr
);
6459 if (attr
.allocatable
6460 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6461 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6462 "allocated", e
->symtree
->n
.sym
->name
);
6463 else if (attr
.pointer
6464 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6465 msg
= xasprintf ("Pointer actual argument '%s' is not "
6466 "associated", e
->symtree
->n
.sym
->name
);
6467 else if (attr
.proc_pointer
6468 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6469 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6470 "associated", e
->symtree
->n
.sym
->name
);
6472 goto end_pointer_check
;
6476 /* If the argument is passed by value, we need to strip the
6478 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6479 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6481 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6482 logical_type_node
, tmp
,
6483 fold_convert (TREE_TYPE (tmp
),
6484 null_pointer_node
));
6487 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6493 /* Deferred length dummies pass the character length by reference
6494 so that the value can be returned. */
6495 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6497 if (INDIRECT_REF_P (parmse
.string_length
))
6498 /* In chains of functions/procedure calls the string_length already
6499 is a pointer to the variable holding the length. Therefore
6500 remove the deref on call. */
6501 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6504 tmp
= parmse
.string_length
;
6505 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6506 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6507 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6511 /* Character strings are passed as two parameters, a length and a
6512 pointer - except for Bind(c) which only passes the pointer.
6513 An unlimited polymorphic formal argument likewise does not
6515 if (parmse
.string_length
!= NULL_TREE
6516 && !sym
->attr
.is_bind_c
6517 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6518 vec_safe_push (stringargs
, parmse
.string_length
);
6520 /* When calling __copy for character expressions to unlimited
6521 polymorphic entities, the dst argument needs a string length. */
6522 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6523 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6524 && arg
->next
&& arg
->next
->expr
6525 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6526 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6527 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6528 vec_safe_push (stringargs
, parmse
.string_length
);
6530 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6531 pass the token and the offset as additional arguments. */
6532 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6533 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6534 && !fsym
->attr
.allocatable
)
6535 || (fsym
->ts
.type
== BT_CLASS
6536 && CLASS_DATA (fsym
)->attr
.codimension
6537 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6539 /* Token and offset. */
6540 vec_safe_push (stringargs
, null_pointer_node
);
6541 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6542 gcc_assert (fsym
->attr
.optional
);
6544 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6545 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6546 && !fsym
->attr
.allocatable
)
6547 || (fsym
->ts
.type
== BT_CLASS
6548 && CLASS_DATA (fsym
)->attr
.codimension
6549 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6551 tree caf_decl
, caf_type
;
6554 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6555 caf_type
= TREE_TYPE (caf_decl
);
6557 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6558 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6559 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6560 tmp
= gfc_conv_descriptor_token (caf_decl
);
6561 else if (DECL_LANG_SPECIFIC (caf_decl
)
6562 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6563 tmp
= GFC_DECL_TOKEN (caf_decl
);
6566 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6567 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6568 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6571 vec_safe_push (stringargs
, tmp
);
6573 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6574 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6575 offset
= build_int_cst (gfc_array_index_type
, 0);
6576 else if (DECL_LANG_SPECIFIC (caf_decl
)
6577 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6578 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6579 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6580 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6582 offset
= build_int_cst (gfc_array_index_type
, 0);
6584 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6585 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6588 gcc_assert (POINTER_TYPE_P (caf_type
));
6592 tmp2
= fsym
->ts
.type
== BT_CLASS
6593 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6594 if ((fsym
->ts
.type
!= BT_CLASS
6595 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6596 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6597 || (fsym
->ts
.type
== BT_CLASS
6598 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6599 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6601 if (fsym
->ts
.type
== BT_CLASS
)
6602 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6605 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6606 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6608 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6609 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6611 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6612 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6615 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6618 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6619 gfc_array_index_type
,
6620 fold_convert (gfc_array_index_type
, tmp2
),
6621 fold_convert (gfc_array_index_type
, tmp
));
6622 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6623 gfc_array_index_type
, offset
, tmp
);
6625 vec_safe_push (stringargs
, offset
);
6628 vec_safe_push (arglist
, parmse
.expr
);
6630 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6634 else if (sym
->ts
.type
== BT_CLASS
)
6635 ts
= CLASS_DATA (sym
)->ts
;
6639 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6640 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6641 else if (ts
.type
== BT_CHARACTER
)
6643 if (ts
.u
.cl
->length
== NULL
)
6645 /* Assumed character length results are not allowed by C418 of the 2003
6646 standard and are trapped in resolve.c; except in the case of SPREAD
6647 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6648 we take the character length of the first argument for the result.
6649 For dummies, we have to look through the formal argument list for
6650 this function and use the character length found there.*/
6652 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6653 else if (!sym
->attr
.dummy
)
6654 cl
.backend_decl
= (*stringargs
)[0];
6657 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6658 for (; formal
; formal
= formal
->next
)
6659 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6660 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6662 len
= cl
.backend_decl
;
6668 /* Calculate the length of the returned string. */
6669 gfc_init_se (&parmse
, NULL
);
6670 if (need_interface_mapping
)
6671 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6673 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6674 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6675 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6677 /* TODO: It would be better to have the charlens as
6678 gfc_charlen_type_node already when the interface is
6679 created instead of converting it here (see PR 84615). */
6680 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6681 gfc_charlen_type_node
,
6682 fold_convert (gfc_charlen_type_node
, tmp
),
6683 build_zero_cst (gfc_charlen_type_node
));
6684 cl
.backend_decl
= tmp
;
6687 /* Set up a charlen structure for it. */
6692 len
= cl
.backend_decl
;
6695 byref
= (comp
&& (comp
->attr
.dimension
6696 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6697 || (!comp
&& gfc_return_by_reference (sym
));
6700 if (se
->direct_byref
)
6702 /* Sometimes, too much indirection can be applied; e.g. for
6703 function_result = array_valued_recursive_function. */
6704 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6705 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6706 && GFC_DESCRIPTOR_TYPE_P
6707 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6708 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6711 /* If the lhs of an assignment x = f(..) is allocatable and
6712 f2003 is allowed, we must do the automatic reallocation.
6713 TODO - deal with intrinsics, without using a temporary. */
6714 if (flag_realloc_lhs
6715 && se
->ss
&& se
->ss
->loop_chain
6716 && se
->ss
->loop_chain
->is_alloc_lhs
6717 && !expr
->value
.function
.isym
6718 && sym
->result
->as
!= NULL
)
6720 /* Evaluate the bounds of the result, if known. */
6721 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6724 /* Perform the automatic reallocation. */
6725 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6727 gfc_add_expr_to_block (&se
->pre
, tmp
);
6729 /* Pass the temporary as the first argument. */
6730 result
= info
->descriptor
;
6733 result
= build_fold_indirect_ref_loc (input_location
,
6735 vec_safe_push (retargs
, se
->expr
);
6737 else if (comp
&& comp
->attr
.dimension
)
6739 gcc_assert (se
->loop
&& info
);
6741 /* Set the type of the array. */
6742 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6743 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6745 /* Evaluate the bounds of the result, if known. */
6746 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6748 /* If the lhs of an assignment x = f(..) is allocatable and
6749 f2003 is allowed, we must not generate the function call
6750 here but should just send back the results of the mapping.
6751 This is signalled by the function ss being flagged. */
6752 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6754 gfc_free_interface_mapping (&mapping
);
6755 return has_alternate_specifier
;
6758 /* Create a temporary to store the result. In case the function
6759 returns a pointer, the temporary will be a shallow copy and
6760 mustn't be deallocated. */
6761 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6762 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6763 tmp
, NULL_TREE
, false,
6764 !comp
->attr
.pointer
, callee_alloc
,
6765 &se
->ss
->info
->expr
->where
);
6767 /* Pass the temporary as the first argument. */
6768 result
= info
->descriptor
;
6769 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6770 vec_safe_push (retargs
, tmp
);
6772 else if (!comp
&& sym
->result
->attr
.dimension
)
6774 gcc_assert (se
->loop
&& info
);
6776 /* Set the type of the array. */
6777 tmp
= gfc_typenode_for_spec (&ts
);
6778 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6780 /* Evaluate the bounds of the result, if known. */
6781 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6783 /* If the lhs of an assignment x = f(..) is allocatable and
6784 f2003 is allowed, we must not generate the function call
6785 here but should just send back the results of the mapping.
6786 This is signalled by the function ss being flagged. */
6787 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6789 gfc_free_interface_mapping (&mapping
);
6790 return has_alternate_specifier
;
6793 /* Create a temporary to store the result. In case the function
6794 returns a pointer, the temporary will be a shallow copy and
6795 mustn't be deallocated. */
6796 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6797 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6798 tmp
, NULL_TREE
, false,
6799 !sym
->attr
.pointer
, callee_alloc
,
6800 &se
->ss
->info
->expr
->where
);
6802 /* Pass the temporary as the first argument. */
6803 result
= info
->descriptor
;
6804 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6805 vec_safe_push (retargs
, tmp
);
6807 else if (ts
.type
== BT_CHARACTER
)
6809 /* Pass the string length. */
6810 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6811 type
= build_pointer_type (type
);
6813 /* Emit a DECL_EXPR for the VLA type. */
6814 tmp
= TREE_TYPE (type
);
6816 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6818 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6819 DECL_ARTIFICIAL (tmp
) = 1;
6820 DECL_IGNORED_P (tmp
) = 1;
6821 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6822 TREE_TYPE (tmp
), tmp
);
6823 gfc_add_expr_to_block (&se
->pre
, tmp
);
6826 /* Return an address to a char[0:len-1]* temporary for
6827 character pointers. */
6828 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6829 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6831 var
= gfc_create_var (type
, "pstr");
6833 if ((!comp
&& sym
->attr
.allocatable
)
6834 || (comp
&& comp
->attr
.allocatable
))
6836 gfc_add_modify (&se
->pre
, var
,
6837 fold_convert (TREE_TYPE (var
),
6838 null_pointer_node
));
6839 tmp
= gfc_call_free (var
);
6840 gfc_add_expr_to_block (&se
->post
, tmp
);
6843 /* Provide an address expression for the function arguments. */
6844 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6847 var
= gfc_conv_string_tmp (se
, type
, len
);
6849 vec_safe_push (retargs
, var
);
6853 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6855 type
= gfc_get_complex_type (ts
.kind
);
6856 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6857 vec_safe_push (retargs
, var
);
6860 /* Add the string length to the argument list. */
6861 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6865 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6866 TREE_STATIC (tmp
) = 1;
6867 gfc_add_modify (&se
->pre
, tmp
,
6868 build_int_cst (TREE_TYPE (tmp
), 0));
6869 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6870 vec_safe_push (retargs
, tmp
);
6872 else if (ts
.type
== BT_CHARACTER
)
6873 vec_safe_push (retargs
, len
);
6875 gfc_free_interface_mapping (&mapping
);
6877 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6878 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6879 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6880 vec_safe_reserve (retargs
, arglen
);
6882 /* Add the return arguments. */
6883 vec_safe_splice (retargs
, arglist
);
6885 /* Add the hidden present status for optional+value to the arguments. */
6886 vec_safe_splice (retargs
, optionalargs
);
6888 /* Add the hidden string length parameters to the arguments. */
6889 vec_safe_splice (retargs
, stringargs
);
6891 /* We may want to append extra arguments here. This is used e.g. for
6892 calls to libgfortran_matmul_??, which need extra information. */
6893 vec_safe_splice (retargs
, append_args
);
6897 /* Generate the actual call. */
6898 if (base_object
== NULL_TREE
)
6899 conv_function_val (se
, sym
, expr
, args
);
6901 conv_base_obj_fcn_val (se
, base_object
, expr
);
6903 /* If there are alternate return labels, function type should be
6904 integer. Can't modify the type in place though, since it can be shared
6905 with other functions. For dummy arguments, the typing is done to
6906 this result, even if it has to be repeated for each call. */
6907 if (has_alternate_specifier
6908 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6910 if (!sym
->attr
.dummy
)
6912 TREE_TYPE (sym
->backend_decl
)
6913 = build_function_type (integer_type_node
,
6914 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6915 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6918 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6921 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6922 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6924 /* Allocatable scalar function results must be freed and nullified
6925 after use. This necessitates the creation of a temporary to
6926 hold the result to prevent duplicate calls. */
6927 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6928 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6929 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6931 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6932 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6934 tmp
= gfc_call_free (tmp
);
6935 gfc_add_expr_to_block (&post
, tmp
);
6936 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6939 /* If we have a pointer function, but we don't want a pointer, e.g.
6942 where f is pointer valued, we have to dereference the result. */
6943 if (!se
->want_pointer
&& !byref
6944 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6945 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6946 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6948 /* f2c calling conventions require a scalar default real function to
6949 return a double precision result. Convert this back to default
6950 real. We only care about the cases that can happen in Fortran 77.
6952 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6953 && sym
->ts
.kind
== gfc_default_real_kind
6954 && !sym
->attr
.always_explicit
)
6955 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6957 /* A pure function may still have side-effects - it may modify its
6959 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6961 if (!sym
->attr
.pure
)
6962 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6967 /* Add the function call to the pre chain. There is no expression. */
6968 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6969 se
->expr
= NULL_TREE
;
6971 if (!se
->direct_byref
)
6973 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6975 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6977 /* Check the data pointer hasn't been modified. This would
6978 happen in a function returning a pointer. */
6979 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6980 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6983 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6986 se
->expr
= info
->descriptor
;
6987 /* Bundle in the string length. */
6988 se
->string_length
= len
;
6990 else if (ts
.type
== BT_CHARACTER
)
6992 /* Dereference for character pointer results. */
6993 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6994 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6995 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6999 se
->string_length
= len
;
7003 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7004 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7009 /* Associate the rhs class object's meta-data with the result, when the
7010 result is a temporary. */
7011 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7012 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7013 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7016 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7018 gfc_init_se (&parmse
, NULL
);
7019 parmse
.data_not_needed
= 1;
7020 gfc_conv_expr (&parmse
, class_expr
);
7021 if (!DECL_LANG_SPECIFIC (result
))
7022 gfc_allocate_lang_decl (result
);
7023 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7024 gfc_free_expr (class_expr
);
7025 /* -fcheck= can add diagnostic code, which has to be placed before
7027 if (parmse
.pre
.head
!= NULL
)
7028 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7029 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7032 /* Follow the function call with the argument post block. */
7035 gfc_add_block_to_block (&se
->pre
, &post
);
7037 /* Transformational functions of derived types with allocatable
7038 components must have the result allocatable components copied when the
7039 argument is actually given. */
7040 arg
= expr
->value
.function
.actual
;
7041 if (result
&& arg
&& expr
->rank
7042 && expr
->value
.function
.isym
7043 && expr
->value
.function
.isym
->transformational
7045 && arg
->expr
->ts
.type
== BT_DERIVED
7046 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7049 /* Copy the allocatable components. We have to use a
7050 temporary here to prevent source allocatable components
7051 from being corrupted. */
7052 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7053 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7054 result
, tmp2
, expr
->rank
, 0);
7055 gfc_add_expr_to_block (&se
->pre
, tmp
);
7056 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7058 gfc_add_expr_to_block (&se
->pre
, tmp
);
7060 /* Finally free the temporary's data field. */
7061 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7062 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7063 NULL_TREE
, NULL_TREE
, true,
7064 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7065 gfc_add_expr_to_block (&se
->pre
, tmp
);
7070 /* For a function with a class array result, save the result as
7071 a temporary, set the info fields needed by the scalarizer and
7072 call the finalization function of the temporary. Note that the
7073 nullification of allocatable components needed by the result
7074 is done in gfc_trans_assignment_1. */
7075 if (expr
&& ((gfc_is_class_array_function (expr
)
7076 && se
->ss
&& se
->ss
->loop
)
7077 || gfc_is_alloc_class_scalar_function (expr
))
7078 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7079 && expr
->must_finalize
)
7084 if (se
->ss
&& se
->ss
->loop
)
7086 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7087 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7088 tmp
= gfc_class_data_get (se
->expr
);
7089 info
->descriptor
= tmp
;
7090 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7091 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7092 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7094 tree dim
= gfc_rank_cst
[n
];
7095 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7096 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7101 /* TODO Eliminate the doubling of temporaries. This
7102 one is necessary to ensure no memory leakage. */
7103 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7104 tmp
= gfc_class_data_get (se
->expr
);
7105 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7106 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7109 if ((gfc_is_class_array_function (expr
)
7110 || gfc_is_alloc_class_scalar_function (expr
))
7111 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7112 goto no_finalization
;
7114 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7115 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7118 fold_convert (TREE_TYPE (final_fndecl
),
7119 null_pointer_node
));
7120 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7122 tmp
= build_call_expr_loc (input_location
,
7124 gfc_build_addr_expr (NULL
, tmp
),
7125 gfc_class_vtab_size_get (se
->expr
),
7126 boolean_false_node
);
7127 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7128 void_type_node
, is_final
, tmp
,
7129 build_empty_stmt (input_location
));
7131 if (se
->ss
&& se
->ss
->loop
)
7133 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7134 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7137 fold_convert (TREE_TYPE (info
->data
),
7138 null_pointer_node
));
7139 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7140 void_type_node
, tmp
,
7141 gfc_call_free (info
->data
),
7142 build_empty_stmt (input_location
));
7143 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7148 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7149 classdata
= gfc_class_data_get (se
->expr
);
7150 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7153 fold_convert (TREE_TYPE (classdata
),
7154 null_pointer_node
));
7155 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7156 void_type_node
, tmp
,
7157 gfc_call_free (classdata
),
7158 build_empty_stmt (input_location
));
7159 gfc_add_expr_to_block (&se
->post
, tmp
);
7164 gfc_add_block_to_block (&se
->post
, &post
);
7167 return has_alternate_specifier
;
7171 /* Fill a character string with spaces. */
7174 fill_with_spaces (tree start
, tree type
, tree size
)
7176 stmtblock_t block
, loop
;
7177 tree i
, el
, exit_label
, cond
, tmp
;
7179 /* For a simple char type, we can call memset(). */
7180 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7181 return build_call_expr_loc (input_location
,
7182 builtin_decl_explicit (BUILT_IN_MEMSET
),
7184 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7185 lang_hooks
.to_target_charset (' ')),
7186 fold_convert (size_type_node
, size
));
7188 /* Otherwise, we use a loop:
7189 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7193 /* Initialize variables. */
7194 gfc_init_block (&block
);
7195 i
= gfc_create_var (sizetype
, "i");
7196 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7197 el
= gfc_create_var (build_pointer_type (type
), "el");
7198 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7199 exit_label
= gfc_build_label_decl (NULL_TREE
);
7200 TREE_USED (exit_label
) = 1;
7204 gfc_init_block (&loop
);
7206 /* Exit condition. */
7207 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7208 build_zero_cst (sizetype
));
7209 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7210 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7211 build_empty_stmt (input_location
));
7212 gfc_add_expr_to_block (&loop
, tmp
);
7215 gfc_add_modify (&loop
,
7216 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7217 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7219 /* Increment loop variables. */
7220 gfc_add_modify (&loop
, i
,
7221 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7222 TYPE_SIZE_UNIT (type
)));
7223 gfc_add_modify (&loop
, el
,
7224 fold_build_pointer_plus_loc (input_location
,
7225 el
, TYPE_SIZE_UNIT (type
)));
7227 /* Making the loop... actually loop! */
7228 tmp
= gfc_finish_block (&loop
);
7229 tmp
= build1_v (LOOP_EXPR
, tmp
);
7230 gfc_add_expr_to_block (&block
, tmp
);
7232 /* The exit label. */
7233 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7234 gfc_add_expr_to_block (&block
, tmp
);
7237 return gfc_finish_block (&block
);
7241 /* Generate code to copy a string. */
7244 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7245 int dkind
, tree slength
, tree src
, int skind
)
7247 tree tmp
, dlen
, slen
;
7256 stmtblock_t tempblock
;
7258 gcc_assert (dkind
== skind
);
7260 if (slength
!= NULL_TREE
)
7262 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7263 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
7267 slen
= build_one_cst (gfc_charlen_type_node
);
7271 if (dlength
!= NULL_TREE
)
7273 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
7274 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
7278 dlen
= build_one_cst (gfc_charlen_type_node
);
7282 /* Assign directly if the types are compatible. */
7283 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
7284 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
7286 gfc_add_modify (block
, dsc
, ssc
);
7290 /* The string copy algorithm below generates code like
7294 if (srclen < destlen)
7296 memmove (dest, src, srclen);
7298 memset (&dest[srclen], ' ', destlen - srclen);
7302 // Truncate if too long.
7303 memmove (dest, src, destlen);
7308 /* Do nothing if the destination length is zero. */
7309 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
7310 build_zero_cst (TREE_TYPE (dlen
)));
7312 /* For non-default character kinds, we have to multiply the string
7313 length by the base type size. */
7314 chartype
= gfc_get_char_type (dkind
);
7315 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
7317 fold_convert (TREE_TYPE (slen
),
7318 TYPE_SIZE_UNIT (chartype
)));
7319 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
7321 fold_convert (TREE_TYPE (dlen
),
7322 TYPE_SIZE_UNIT (chartype
)));
7324 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
7325 dest
= fold_convert (pvoid_type_node
, dest
);
7327 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
7329 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
7330 src
= fold_convert (pvoid_type_node
, src
);
7332 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7334 /* Truncate string if source is too long. */
7335 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
7338 /* Copy and pad with spaces. */
7339 tmp3
= build_call_expr_loc (input_location
,
7340 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7342 fold_convert (size_type_node
, slen
));
7344 /* Wstringop-overflow appears at -O3 even though this warning is not
7345 explicitly available in fortran nor can it be switched off. If the
7346 source length is a constant, its negative appears as a very large
7347 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7348 the result of the MINUS_EXPR suppresses this spurious warning. */
7349 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7350 TREE_TYPE(dlen
), dlen
, slen
);
7351 if (slength
&& TREE_CONSTANT (slength
))
7352 tmp
= gfc_evaluate_now (tmp
, block
);
7354 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
7355 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
7357 gfc_init_block (&tempblock
);
7358 gfc_add_expr_to_block (&tempblock
, tmp3
);
7359 gfc_add_expr_to_block (&tempblock
, tmp4
);
7360 tmp3
= gfc_finish_block (&tempblock
);
7362 /* The truncated memmove if the slen >= dlen. */
7363 tmp2
= build_call_expr_loc (input_location
,
7364 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
7366 fold_convert (size_type_node
, dlen
));
7368 /* The whole copy_string function is there. */
7369 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
7371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7372 build_empty_stmt (input_location
));
7373 gfc_add_expr_to_block (block
, tmp
);
7377 /* Translate a statement function.
7378 The value of a statement function reference is obtained by evaluating the
7379 expression using the values of the actual arguments for the values of the
7380 corresponding dummy arguments. */
7383 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
7387 gfc_formal_arglist
*fargs
;
7388 gfc_actual_arglist
*args
;
7391 gfc_saved_var
*saved_vars
;
7397 sym
= expr
->symtree
->n
.sym
;
7398 args
= expr
->value
.function
.actual
;
7399 gfc_init_se (&lse
, NULL
);
7400 gfc_init_se (&rse
, NULL
);
7403 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7405 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7406 temp_vars
= XCNEWVEC (tree
, n
);
7408 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7409 fargs
= fargs
->next
, n
++)
7411 /* Each dummy shall be specified, explicitly or implicitly, to be
7413 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7416 if (fsym
->ts
.type
== BT_CHARACTER
)
7418 /* Copy string arguments. */
7421 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7422 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7424 /* Create a temporary to hold the value. */
7425 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7426 fsym
->ts
.u
.cl
->backend_decl
7427 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7429 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7430 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7432 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7434 gfc_conv_expr (&rse
, args
->expr
);
7435 gfc_conv_string_parameter (&rse
);
7436 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7437 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7439 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7440 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7441 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7442 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7446 /* For everything else, just evaluate the expression. */
7448 /* Create a temporary to hold the value. */
7449 type
= gfc_typenode_for_spec (&fsym
->ts
);
7450 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7452 gfc_conv_expr (&lse
, args
->expr
);
7454 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7455 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7456 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7462 /* Use the temporary variables in place of the real ones. */
7463 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7464 fargs
= fargs
->next
, n
++)
7465 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7467 gfc_conv_expr (se
, sym
->value
);
7469 if (sym
->ts
.type
== BT_CHARACTER
)
7471 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7473 /* Force the expression to the correct length. */
7474 if (!INTEGER_CST_P (se
->string_length
)
7475 || tree_int_cst_lt (se
->string_length
,
7476 sym
->ts
.u
.cl
->backend_decl
))
7478 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7479 tmp
= gfc_create_var (type
, sym
->name
);
7480 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7481 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7482 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7486 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7489 /* Restore the original variables. */
7490 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7491 fargs
= fargs
->next
, n
++)
7492 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7498 /* Translate a function expression. */
7501 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7505 if (expr
->value
.function
.isym
)
7507 gfc_conv_intrinsic_function (se
, expr
);
7511 /* expr.value.function.esym is the resolved (specific) function symbol for
7512 most functions. However this isn't set for dummy procedures. */
7513 sym
= expr
->value
.function
.esym
;
7515 sym
= expr
->symtree
->n
.sym
;
7517 /* The IEEE_ARITHMETIC functions are caught here. */
7518 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7519 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7522 /* We distinguish statement functions from general functions to improve
7523 runtime performance. */
7524 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7526 gfc_conv_statement_function (se
, expr
);
7530 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7535 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7538 is_zero_initializer_p (gfc_expr
* expr
)
7540 if (expr
->expr_type
!= EXPR_CONSTANT
)
7543 /* We ignore constants with prescribed memory representations for now. */
7544 if (expr
->representation
.string
)
7547 switch (expr
->ts
.type
)
7550 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7553 return mpfr_zero_p (expr
->value
.real
)
7554 && MPFR_SIGN (expr
->value
.real
) >= 0;
7557 return expr
->value
.logical
== 0;
7560 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7561 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7562 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7563 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7573 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7578 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7579 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7581 gfc_conv_tmp_array_ref (se
);
7585 /* Build a static initializer. EXPR is the expression for the initial value.
7586 The other parameters describe the variable of the component being
7587 initialized. EXPR may be null. */
7590 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7591 bool array
, bool pointer
, bool procptr
)
7595 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7596 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7597 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7598 return build_constructor (type
, NULL
);
7600 if (!(expr
|| pointer
|| procptr
))
7603 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7604 (these are the only two iso_c_binding derived types that can be
7605 used as initialization expressions). If so, we need to modify
7606 the 'expr' to be that for a (void *). */
7607 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7608 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7610 if (TREE_CODE (type
) == ARRAY_TYPE
)
7611 return build_constructor (type
, NULL
);
7612 else if (POINTER_TYPE_P (type
))
7613 return build_int_cst (type
, 0);
7618 if (array
&& !procptr
)
7621 /* Arrays need special handling. */
7623 ctor
= gfc_build_null_descriptor (type
);
7624 /* Special case assigning an array to zero. */
7625 else if (is_zero_initializer_p (expr
))
7626 ctor
= build_constructor (type
, NULL
);
7628 ctor
= gfc_conv_array_initializer (type
, expr
);
7629 TREE_STATIC (ctor
) = 1;
7632 else if (pointer
|| procptr
)
7634 if (ts
->type
== BT_CLASS
&& !procptr
)
7636 gfc_init_se (&se
, NULL
);
7637 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7638 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7639 TREE_STATIC (se
.expr
) = 1;
7642 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7643 return fold_convert (type
, null_pointer_node
);
7646 gfc_init_se (&se
, NULL
);
7647 se
.want_pointer
= 1;
7648 gfc_conv_expr (&se
, expr
);
7649 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7659 gfc_init_se (&se
, NULL
);
7660 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7661 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7663 gfc_conv_structure (&se
, expr
, 1);
7664 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7665 TREE_STATIC (se
.expr
) = 1;
7669 if (expr
->expr_type
== EXPR_CONSTANT
)
7671 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
, expr
);
7672 TREE_STATIC (ctor
) = 1;
7678 gfc_init_se (&se
, NULL
);
7679 gfc_conv_constant (&se
, expr
);
7680 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7687 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7693 gfc_array_info
*lss_array
;
7700 gfc_start_block (&block
);
7702 /* Initialize the scalarizer. */
7703 gfc_init_loopinfo (&loop
);
7705 gfc_init_se (&lse
, NULL
);
7706 gfc_init_se (&rse
, NULL
);
7709 rss
= gfc_walk_expr (expr
);
7710 if (rss
== gfc_ss_terminator
)
7711 /* The rhs is scalar. Add a ss for the expression. */
7712 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7714 /* Create a SS for the destination. */
7715 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7717 lss_array
= &lss
->info
->data
.array
;
7718 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7719 lss_array
->descriptor
= dest
;
7720 lss_array
->data
= gfc_conv_array_data (dest
);
7721 lss_array
->offset
= gfc_conv_array_offset (dest
);
7722 for (n
= 0; n
< cm
->as
->rank
; n
++)
7724 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7725 lss_array
->stride
[n
] = gfc_index_one_node
;
7727 mpz_init (lss_array
->shape
[n
]);
7728 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7729 cm
->as
->lower
[n
]->value
.integer
);
7730 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7733 /* Associate the SS with the loop. */
7734 gfc_add_ss_to_loop (&loop
, lss
);
7735 gfc_add_ss_to_loop (&loop
, rss
);
7737 /* Calculate the bounds of the scalarization. */
7738 gfc_conv_ss_startstride (&loop
);
7740 /* Setup the scalarizing loops. */
7741 gfc_conv_loop_setup (&loop
, &expr
->where
);
7743 /* Setup the gfc_se structures. */
7744 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7745 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7748 gfc_mark_ss_chain_used (rss
, 1);
7750 gfc_mark_ss_chain_used (lss
, 1);
7752 /* Start the scalarized loop body. */
7753 gfc_start_scalarized_body (&loop
, &body
);
7755 gfc_conv_tmp_array_ref (&lse
);
7756 if (cm
->ts
.type
== BT_CHARACTER
)
7757 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7759 gfc_conv_expr (&rse
, expr
);
7761 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7762 gfc_add_expr_to_block (&body
, tmp
);
7764 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7766 /* Generate the copying loops. */
7767 gfc_trans_scalarizing_loops (&loop
, &body
);
7769 /* Wrap the whole thing up. */
7770 gfc_add_block_to_block (&block
, &loop
.pre
);
7771 gfc_add_block_to_block (&block
, &loop
.post
);
7773 gcc_assert (lss_array
->shape
!= NULL
);
7774 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7775 gfc_cleanup_loop (&loop
);
7777 return gfc_finish_block (&block
);
7782 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7792 gfc_expr
*arg
= NULL
;
7794 gfc_start_block (&block
);
7795 gfc_init_se (&se
, NULL
);
7797 /* Get the descriptor for the expressions. */
7798 se
.want_pointer
= 0;
7799 gfc_conv_expr_descriptor (&se
, expr
);
7800 gfc_add_block_to_block (&block
, &se
.pre
);
7801 gfc_add_modify (&block
, dest
, se
.expr
);
7803 /* Deal with arrays of derived types with allocatable components. */
7804 if (gfc_bt_struct (cm
->ts
.type
)
7805 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7806 // TODO: Fix caf_mode
7807 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7810 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7811 && CLASS_DATA(cm
)->attr
.allocatable
)
7813 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7814 // TODO: Fix caf_mode
7815 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7820 tmp
= TREE_TYPE (dest
);
7821 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7822 tmp
, expr
->rank
, NULL_TREE
);
7826 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7827 TREE_TYPE(cm
->backend_decl
),
7828 cm
->as
->rank
, NULL_TREE
);
7830 gfc_add_expr_to_block (&block
, tmp
);
7831 gfc_add_block_to_block (&block
, &se
.post
);
7833 if (expr
->expr_type
!= EXPR_VARIABLE
)
7834 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7837 /* We need to know if the argument of a conversion function is a
7838 variable, so that the correct lower bound can be used. */
7839 if (expr
->expr_type
== EXPR_FUNCTION
7840 && expr
->value
.function
.isym
7841 && expr
->value
.function
.isym
->conversion
7842 && expr
->value
.function
.actual
->expr
7843 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7844 arg
= expr
->value
.function
.actual
->expr
;
7846 /* Obtain the array spec of full array references. */
7848 as
= gfc_get_full_arrayspec_from_expr (arg
);
7850 as
= gfc_get_full_arrayspec_from_expr (expr
);
7852 /* Shift the lbound and ubound of temporaries to being unity,
7853 rather than zero, based. Always calculate the offset. */
7854 offset
= gfc_conv_descriptor_offset_get (dest
);
7855 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7856 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7858 for (n
= 0; n
< expr
->rank
; n
++)
7863 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7864 TODO It looks as if gfc_conv_expr_descriptor should return
7865 the correct bounds and that the following should not be
7866 necessary. This would simplify gfc_conv_intrinsic_bound
7868 if (as
&& as
->lower
[n
])
7871 gfc_init_se (&lbse
, NULL
);
7872 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7873 gfc_add_block_to_block (&block
, &lbse
.pre
);
7874 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7878 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7879 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7883 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7886 lbound
= gfc_index_one_node
;
7888 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7890 /* Shift the bounds and set the offset accordingly. */
7891 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7892 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7893 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7894 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7896 gfc_conv_descriptor_ubound_set (&block
, dest
,
7897 gfc_rank_cst
[n
], tmp
);
7898 gfc_conv_descriptor_lbound_set (&block
, dest
,
7899 gfc_rank_cst
[n
], lbound
);
7901 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7902 gfc_conv_descriptor_lbound_get (dest
,
7904 gfc_conv_descriptor_stride_get (dest
,
7906 gfc_add_modify (&block
, tmp2
, tmp
);
7907 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7909 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7914 /* If a conversion expression has a null data pointer
7915 argument, nullify the allocatable component. */
7919 if (arg
->symtree
->n
.sym
->attr
.allocatable
7920 || arg
->symtree
->n
.sym
->attr
.pointer
)
7922 non_null_expr
= gfc_finish_block (&block
);
7923 gfc_start_block (&block
);
7924 gfc_conv_descriptor_data_set (&block
, dest
,
7926 null_expr
= gfc_finish_block (&block
);
7927 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7928 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7929 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7930 return build3_v (COND_EXPR
, tmp
,
7931 null_expr
, non_null_expr
);
7935 return gfc_finish_block (&block
);
7939 /* Allocate or reallocate scalar component, as necessary. */
7942 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7952 tree lhs_cl_size
= NULL_TREE
;
7957 if (!expr2
|| expr2
->rank
)
7960 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7962 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7964 char name
[GFC_MAX_SYMBOL_LEN
+9];
7965 gfc_component
*strlen
;
7966 /* Use the rhs string length and the lhs element size. */
7967 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7968 if (!expr2
->ts
.u
.cl
->backend_decl
)
7970 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7971 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7974 size
= expr2
->ts
.u
.cl
->backend_decl
;
7976 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7978 sprintf (name
, "_%s_length", cm
->name
);
7979 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7980 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7981 gfc_charlen_type_node
,
7982 TREE_OPERAND (comp
, 0),
7983 strlen
->backend_decl
, NULL_TREE
);
7985 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7986 tmp
= TYPE_SIZE_UNIT (tmp
);
7987 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7988 TREE_TYPE (tmp
), tmp
,
7989 fold_convert (TREE_TYPE (tmp
), size
));
7991 else if (cm
->ts
.type
== BT_CLASS
)
7993 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7994 if (expr2
->ts
.type
== BT_DERIVED
)
7996 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7997 size
= TYPE_SIZE_UNIT (tmp
);
8003 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8004 gfc_add_vptr_component (e2vtab
);
8005 gfc_add_size_component (e2vtab
);
8006 gfc_init_se (&se
, NULL
);
8007 gfc_conv_expr (&se
, e2vtab
);
8008 gfc_add_block_to_block (block
, &se
.pre
);
8009 size
= fold_convert (size_type_node
, se
.expr
);
8010 gfc_free_expr (e2vtab
);
8012 size_in_bytes
= size
;
8016 /* Otherwise use the length in bytes of the rhs. */
8017 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8018 size_in_bytes
= size
;
8021 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8022 size_in_bytes
, size_one_node
);
8024 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8026 tmp
= build_call_expr_loc (input_location
,
8027 builtin_decl_explicit (BUILT_IN_CALLOC
),
8028 2, build_one_cst (size_type_node
),
8030 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8031 gfc_add_modify (block
, comp
, tmp
);
8035 tmp
= build_call_expr_loc (input_location
,
8036 builtin_decl_explicit (BUILT_IN_MALLOC
),
8038 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8039 ptr
= gfc_class_data_get (comp
);
8042 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8043 gfc_add_modify (block
, ptr
, tmp
);
8046 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8047 /* Update the lhs character length. */
8048 gfc_add_modify (block
, lhs_cl_size
,
8049 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8053 /* Assign a single component of a derived type constructor. */
8056 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8057 gfc_symbol
*sym
, bool init
)
8065 gfc_start_block (&block
);
8067 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8069 /* Only care about pointers here, not about allocatables. */
8070 gfc_init_se (&se
, NULL
);
8071 /* Pointer component. */
8072 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8073 && !cm
->attr
.proc_pointer
)
8075 /* Array pointer. */
8076 if (expr
->expr_type
== EXPR_NULL
)
8077 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8080 se
.direct_byref
= 1;
8082 gfc_conv_expr_descriptor (&se
, expr
);
8083 gfc_add_block_to_block (&block
, &se
.pre
);
8084 gfc_add_block_to_block (&block
, &se
.post
);
8089 /* Scalar pointers. */
8090 se
.want_pointer
= 1;
8091 gfc_conv_expr (&se
, expr
);
8092 gfc_add_block_to_block (&block
, &se
.pre
);
8094 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8095 && expr
->symtree
->n
.sym
->attr
.dummy
)
8096 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8098 gfc_add_modify (&block
, dest
,
8099 fold_convert (TREE_TYPE (dest
), se
.expr
));
8100 gfc_add_block_to_block (&block
, &se
.post
);
8103 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8105 /* NULL initialization for CLASS components. */
8106 tmp
= gfc_trans_structure_assign (dest
,
8107 gfc_class_initializer (&cm
->ts
, expr
),
8109 gfc_add_expr_to_block (&block
, tmp
);
8111 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8112 && !cm
->attr
.proc_pointer
)
8114 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8115 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8116 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8118 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8119 gfc_add_expr_to_block (&block
, tmp
);
8123 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8124 gfc_add_expr_to_block (&block
, tmp
);
8127 else if (cm
->ts
.type
== BT_CLASS
8128 && CLASS_DATA (cm
)->attr
.dimension
8129 && CLASS_DATA (cm
)->attr
.allocatable
8130 && expr
->ts
.type
== BT_DERIVED
)
8132 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8133 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8134 tmp
= gfc_class_vptr_get (dest
);
8135 gfc_add_modify (&block
, tmp
,
8136 fold_convert (TREE_TYPE (tmp
), vtab
));
8137 tmp
= gfc_class_data_get (dest
);
8138 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8139 gfc_add_expr_to_block (&block
, tmp
);
8141 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8143 /* NULL initialization for allocatable components. */
8144 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8145 null_pointer_node
));
8147 else if (init
&& (cm
->attr
.allocatable
8148 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8149 && expr
->ts
.type
!= BT_CLASS
)))
8151 /* Take care about non-array allocatable components here. The alloc_*
8152 routine below is motivated by the alloc_scalar_allocatable_for_
8153 assignment() routine, but with the realloc portions removed and
8155 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8160 /* The remainder of these instructions follow the if (cm->attr.pointer)
8161 if (!cm->attr.dimension) part above. */
8162 gfc_init_se (&se
, NULL
);
8163 gfc_conv_expr (&se
, expr
);
8164 gfc_add_block_to_block (&block
, &se
.pre
);
8166 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8167 && expr
->symtree
->n
.sym
->attr
.dummy
)
8168 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8170 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8172 tmp
= gfc_class_data_get (dest
);
8173 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8174 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8175 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8176 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8177 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8180 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8182 /* For deferred strings insert a memcpy. */
8183 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8186 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8187 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8189 : expr
->ts
.u
.cl
->backend_decl
);
8190 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8191 gfc_add_expr_to_block (&block
, tmp
);
8194 gfc_add_modify (&block
, tmp
,
8195 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8196 gfc_add_block_to_block (&block
, &se
.post
);
8198 else if (expr
->ts
.type
== BT_UNION
)
8201 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8202 /* We mark that the entire union should be initialized with a contrived
8203 EXPR_NULL expression at the beginning. */
8204 if (c
!= NULL
&& c
->n
.component
== NULL
8205 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8207 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8208 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8209 gfc_add_expr_to_block (&block
, tmp
);
8210 c
= gfc_constructor_next (c
);
8212 /* The following constructor expression, if any, represents a specific
8213 map intializer, as given by the user. */
8214 if (c
!= NULL
&& c
->expr
!= NULL
)
8216 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8217 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8218 gfc_add_expr_to_block (&block
, tmp
);
8221 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8223 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8225 tree dealloc
= NULL_TREE
;
8226 gfc_init_se (&se
, NULL
);
8227 gfc_conv_expr (&se
, expr
);
8228 gfc_add_block_to_block (&block
, &se
.pre
);
8229 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8230 expression in a temporary variable and deallocate the allocatable
8231 components. Then we can the copy the expression to the result. */
8232 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8233 && expr
->expr_type
!= EXPR_VARIABLE
)
8235 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8236 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8239 gfc_add_modify (&block
, dest
,
8240 fold_convert (TREE_TYPE (dest
), se
.expr
));
8241 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8242 && expr
->expr_type
!= EXPR_NULL
)
8244 // TODO: Fix caf_mode
8245 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8246 dest
, expr
->rank
, 0);
8247 gfc_add_expr_to_block (&block
, tmp
);
8248 if (dealloc
!= NULL_TREE
)
8249 gfc_add_expr_to_block (&block
, dealloc
);
8251 gfc_add_block_to_block (&block
, &se
.post
);
8255 /* Nested constructors. */
8256 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8257 gfc_add_expr_to_block (&block
, tmp
);
8260 else if (gfc_deferred_strlen (cm
, &tmp
))
8264 gcc_assert (strlen
);
8265 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
8267 TREE_OPERAND (dest
, 0),
8270 if (expr
->expr_type
== EXPR_NULL
)
8272 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
8273 gfc_add_modify (&block
, dest
, tmp
);
8274 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
8275 gfc_add_modify (&block
, strlen
, tmp
);
8280 gfc_init_se (&se
, NULL
);
8281 gfc_conv_expr (&se
, expr
);
8282 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
8283 tmp
= build_call_expr_loc (input_location
,
8284 builtin_decl_explicit (BUILT_IN_MALLOC
),
8286 gfc_add_modify (&block
, dest
,
8287 fold_convert (TREE_TYPE (dest
), tmp
));
8288 gfc_add_modify (&block
, strlen
,
8289 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
8290 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
8291 gfc_add_expr_to_block (&block
, tmp
);
8294 else if (!cm
->attr
.artificial
)
8296 /* Scalar component (excluding deferred parameters). */
8297 gfc_init_se (&se
, NULL
);
8298 gfc_init_se (&lse
, NULL
);
8300 gfc_conv_expr (&se
, expr
);
8301 if (cm
->ts
.type
== BT_CHARACTER
)
8302 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8304 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
8305 gfc_add_expr_to_block (&block
, tmp
);
8307 return gfc_finish_block (&block
);
8310 /* Assign a derived type constructor to a variable. */
8313 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
8322 gfc_start_block (&block
);
8323 cm
= expr
->ts
.u
.derived
->components
;
8325 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
8326 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
8327 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
8331 gfc_init_se (&se
, NULL
);
8332 gfc_init_se (&lse
, NULL
);
8333 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
8335 gfc_add_modify (&block
, lse
.expr
,
8336 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
8338 return gfc_finish_block (&block
);
8342 gfc_init_se (&se
, NULL
);
8344 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8345 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8347 /* Skip absent members in default initializers. */
8348 if (!c
->expr
&& !cm
->attr
.allocatable
)
8351 /* Register the component with the caf-lib before it is initialized.
8352 Register only allocatable components, that are not coarray'ed
8353 components (%comp[*]). Only register when the constructor is not the
8355 if (coarray
&& !cm
->attr
.codimension
8356 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
8357 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
8359 tree token
, desc
, size
;
8360 bool is_array
= cm
->ts
.type
== BT_CLASS
8361 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
8363 field
= cm
->backend_decl
;
8364 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
8365 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
8366 if (cm
->ts
.type
== BT_CLASS
)
8367 field
= gfc_class_data_get (field
);
8369 token
= is_array
? gfc_conv_descriptor_token (field
)
8370 : fold_build3_loc (input_location
, COMPONENT_REF
,
8371 TREE_TYPE (cm
->caf_token
), dest
,
8372 cm
->caf_token
, NULL_TREE
);
8376 /* The _caf_register routine looks at the rank of the array
8377 descriptor to decide whether the data registered is an array
8379 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
8381 /* When the rank is not known just set a positive rank, which
8382 suffices to recognize the data as array. */
8385 size
= build_zero_cst (size_type_node
);
8387 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
8388 build_int_cst (signed_char_type_node
, rank
));
8392 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8393 cm
->ts
.type
== BT_CLASS
8394 ? CLASS_DATA (cm
)->attr
8396 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8398 gfc_add_block_to_block (&block
, &se
.pre
);
8399 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8400 7, size
, build_int_cst (
8402 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8403 gfc_build_addr_expr (pvoid_type_node
,
8405 gfc_build_addr_expr (NULL_TREE
, desc
),
8406 null_pointer_node
, null_pointer_node
,
8408 gfc_add_expr_to_block (&block
, tmp
);
8410 field
= cm
->backend_decl
;
8411 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8412 dest
, field
, NULL_TREE
);
8415 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8416 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8421 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8422 expr
->ts
.u
.derived
, init
);
8423 gfc_add_expr_to_block (&block
, tmp
);
8425 return gfc_finish_block (&block
);
8429 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8430 gfc_component
*un
, gfc_expr
*init
)
8432 gfc_constructor
*ctor
;
8434 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8437 ctor
= gfc_constructor_first (init
->value
.constructor
);
8439 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8442 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8444 /* If we have an 'initialize all' constructor, do it first. */
8445 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8447 tree union_type
= TREE_TYPE (un
->backend_decl
);
8448 tree val
= build_constructor (union_type
, NULL
);
8449 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8450 ctor
= gfc_constructor_next (ctor
);
8453 /* Add the map initializer on top. */
8454 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8456 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8457 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8458 TREE_TYPE (un
->backend_decl
),
8459 un
->attr
.dimension
, un
->attr
.pointer
,
8460 un
->attr
.proc_pointer
);
8461 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8465 /* Build an expression for a constructor. If init is nonzero then
8466 this is part of a static variable initializer. */
8469 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8476 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8478 gcc_assert (se
->ss
== NULL
);
8479 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8480 type
= gfc_typenode_for_spec (&expr
->ts
);
8484 /* Create a temporary variable and fill it in. */
8485 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8486 /* The symtree in expr is NULL, if the code to generate is for
8487 initializing the static members only. */
8488 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8490 gfc_add_expr_to_block (&se
->pre
, tmp
);
8494 cm
= expr
->ts
.u
.derived
->components
;
8496 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8497 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8499 /* Skip absent members in default initializers and allocatable
8500 components. Although the latter have a default initializer
8501 of EXPR_NULL,... by default, the static nullify is not needed
8502 since this is done every time we come into scope. */
8503 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8506 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8507 && strcmp (cm
->name
, "_extends") == 0
8508 && cm
->initializer
->symtree
)
8512 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8513 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8514 vtab
= unshare_expr_without_location (vtab
);
8515 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8517 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8519 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8520 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8521 fold_convert (TREE_TYPE (cm
->backend_decl
),
8524 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8525 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8526 fold_convert (TREE_TYPE (cm
->backend_decl
),
8527 integer_zero_node
));
8528 else if (cm
->ts
.type
== BT_UNION
)
8529 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8532 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8533 TREE_TYPE (cm
->backend_decl
),
8534 cm
->attr
.dimension
, cm
->attr
.pointer
,
8535 cm
->attr
.proc_pointer
);
8536 val
= unshare_expr_without_location (val
);
8538 /* Append it to the constructor list. */
8539 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8543 se
->expr
= build_constructor (type
, v
);
8545 TREE_CONSTANT (se
->expr
) = 1;
8549 /* Translate a substring expression. */
8552 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8558 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8560 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8561 expr
->value
.character
.length
,
8562 expr
->value
.character
.string
);
8564 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8565 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8568 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8572 /* Entry point for expression translation. Evaluates a scalar quantity.
8573 EXPR is the expression to be translated, and SE is the state structure if
8574 called from within the scalarized. */
8577 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8582 if (ss
&& ss
->info
->expr
== expr
8583 && (ss
->info
->type
== GFC_SS_SCALAR
8584 || ss
->info
->type
== GFC_SS_REFERENCE
))
8586 gfc_ss_info
*ss_info
;
8589 /* Substitute a scalar expression evaluated outside the scalarization
8591 se
->expr
= ss_info
->data
.scalar
.value
;
8592 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8593 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8595 se
->string_length
= ss_info
->string_length
;
8596 gfc_advance_se_ss_chain (se
);
8600 /* We need to convert the expressions for the iso_c_binding derived types.
8601 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8602 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8603 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8604 updated to be an integer with a kind equal to the size of a (void *). */
8605 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8606 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8608 if (expr
->expr_type
== EXPR_VARIABLE
8609 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8610 || expr
->symtree
->n
.sym
->intmod_sym_id
8611 == ISOCBINDING_NULL_FUNPTR
))
8613 /* Set expr_type to EXPR_NULL, which will result in
8614 null_pointer_node being used below. */
8615 expr
->expr_type
= EXPR_NULL
;
8619 /* Update the type/kind of the expression to be what the new
8620 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8621 expr
->ts
.type
= BT_INTEGER
;
8622 expr
->ts
.f90_type
= BT_VOID
;
8623 expr
->ts
.kind
= gfc_index_integer_kind
;
8627 gfc_fix_class_refs (expr
);
8629 switch (expr
->expr_type
)
8632 gfc_conv_expr_op (se
, expr
);
8636 gfc_conv_function_expr (se
, expr
);
8640 gfc_conv_constant (se
, expr
);
8644 gfc_conv_variable (se
, expr
);
8648 se
->expr
= null_pointer_node
;
8651 case EXPR_SUBSTRING
:
8652 gfc_conv_substring_expr (se
, expr
);
8655 case EXPR_STRUCTURE
:
8656 gfc_conv_structure (se
, expr
, 0);
8660 gfc_conv_array_constructor_expr (se
, expr
);
8669 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8670 of an assignment. */
8672 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8674 gfc_conv_expr (se
, expr
);
8675 /* All numeric lvalues should have empty post chains. If not we need to
8676 figure out a way of rewriting an lvalue so that it has no post chain. */
8677 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8680 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8681 numeric expressions. Used for scalar values where inserting cleanup code
8684 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8688 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8689 gfc_conv_expr (se
, expr
);
8692 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8693 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8695 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8699 /* Helper to translate an expression and convert it to a particular type. */
8701 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8703 gfc_conv_expr_val (se
, expr
);
8704 se
->expr
= convert (type
, se
->expr
);
8708 /* Converts an expression so that it can be passed by reference. Scalar
8712 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8718 if (ss
&& ss
->info
->expr
== expr
8719 && ss
->info
->type
== GFC_SS_REFERENCE
)
8721 /* Returns a reference to the scalar evaluated outside the loop
8723 gfc_conv_expr (se
, expr
);
8725 if (expr
->ts
.type
== BT_CHARACTER
8726 && expr
->expr_type
!= EXPR_FUNCTION
)
8727 gfc_conv_string_parameter (se
);
8729 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8734 if (expr
->ts
.type
== BT_CHARACTER
)
8736 gfc_conv_expr (se
, expr
);
8737 gfc_conv_string_parameter (se
);
8741 if (expr
->expr_type
== EXPR_VARIABLE
)
8743 se
->want_pointer
= 1;
8744 gfc_conv_expr (se
, expr
);
8747 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8748 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8749 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8752 else if (add_clobber
&& expr
->ref
== NULL
)
8756 /* FIXME: This fails if var is passed by reference, see PR
8758 var
= expr
->symtree
->n
.sym
->backend_decl
;
8759 clobber
= build_clobber (TREE_TYPE (var
));
8760 gfc_add_modify (&se
->pre
, var
, clobber
);
8765 if (expr
->expr_type
== EXPR_FUNCTION
8766 && ((expr
->value
.function
.esym
8767 && expr
->value
.function
.esym
->result
8768 && expr
->value
.function
.esym
->result
->attr
.pointer
8769 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8770 || (!expr
->value
.function
.esym
&& !expr
->ref
8771 && expr
->symtree
->n
.sym
->attr
.pointer
8772 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8774 se
->want_pointer
= 1;
8775 gfc_conv_expr (se
, expr
);
8776 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8777 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8782 gfc_conv_expr (se
, expr
);
8784 /* Create a temporary var to hold the value. */
8785 if (TREE_CONSTANT (se
->expr
))
8787 tree tmp
= se
->expr
;
8788 STRIP_TYPE_NOPS (tmp
);
8789 var
= build_decl (input_location
,
8790 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8791 DECL_INITIAL (var
) = tmp
;
8792 TREE_STATIC (var
) = 1;
8797 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8798 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8801 if (!expr
->must_finalize
)
8802 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8804 /* Take the address of that value. */
8805 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8809 /* Get the _len component for an unlimited polymorphic expression. */
8812 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8815 gfc_ref
*ref
= expr
->ref
;
8817 gfc_init_se (&se
, NULL
);
8818 while (ref
&& ref
->next
)
8820 gfc_add_len_component (expr
);
8821 gfc_conv_expr (&se
, expr
);
8822 gfc_add_block_to_block (block
, &se
.pre
);
8823 gcc_assert (se
.post
.head
== NULL_TREE
);
8826 gfc_free_ref_list (ref
->next
);
8831 gfc_free_ref_list (expr
->ref
);
8838 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8839 statement-list outside of the scalarizer-loop. When code is generated, that
8840 depends on the scalarized expression, it is added to RSE.PRE.
8841 Returns le's _vptr tree and when set the len expressions in to_lenp and
8842 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8846 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8847 gfc_expr
* re
, gfc_se
*rse
,
8848 tree
* to_lenp
, tree
* from_lenp
)
8851 gfc_expr
* vptr_expr
;
8852 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8853 bool set_vptr
= false, temp_rhs
= false;
8854 stmtblock_t
*pre
= block
;
8855 tree class_expr
= NULL_TREE
;
8857 /* Create a temporary for complicated expressions. */
8858 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8859 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8861 if (re
->ts
.type
== BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
8862 class_expr
= gfc_get_class_from_expr (rse
->expr
);
8865 pre
= &rse
->loop
->pre
;
8869 if (class_expr
!= NULL_TREE
&& UNLIMITED_POLY (re
))
8871 tmp
= TREE_OPERAND (rse
->expr
, 0);
8872 tmp
= gfc_create_var (TREE_TYPE (tmp
), "rhs");
8873 gfc_add_modify (&rse
->pre
, tmp
, TREE_OPERAND (rse
->expr
, 0));
8877 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8878 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8885 /* Get the _vptr for the left-hand side expression. */
8886 gfc_init_se (&se
, NULL
);
8887 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8888 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8890 /* Care about _len for unlimited polymorphic entities. */
8891 if (UNLIMITED_POLY (vptr_expr
)
8892 || (vptr_expr
->ts
.type
== BT_DERIVED
8893 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8894 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8895 gfc_add_vptr_component (vptr_expr
);
8899 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8900 se
.want_pointer
= 1;
8901 gfc_conv_expr (&se
, vptr_expr
);
8902 gfc_free_expr (vptr_expr
);
8903 gfc_add_block_to_block (block
, &se
.pre
);
8904 gcc_assert (se
.post
.head
== NULL_TREE
);
8906 STRIP_NOPS (lhs_vptr
);
8908 /* Set the _vptr only when the left-hand side of the assignment is a
8912 /* Get the vptr from the rhs expression only, when it is variable.
8913 Functions are expected to be assigned to a temporary beforehand. */
8914 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8915 ? gfc_find_and_cut_at_last_class_ref (re
)
8917 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8919 if (to_len
!= NULL_TREE
)
8921 /* Get the _len information from the rhs. */
8922 if (UNLIMITED_POLY (vptr_expr
)
8923 || (vptr_expr
->ts
.type
== BT_DERIVED
8924 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8925 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8927 gfc_add_vptr_component (vptr_expr
);
8931 if (re
->expr_type
== EXPR_VARIABLE
8932 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8933 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8934 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8935 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8936 re
->symtree
->n
.sym
->backend_decl
))))
8939 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8940 re
->symtree
->n
.sym
->backend_decl
));
8942 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8943 re
->symtree
->n
.sym
->backend_decl
));
8945 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8950 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
8951 tmp
= gfc_get_class_from_expr (rse
->expr
);
8955 se
.expr
= gfc_class_vptr_get (tmp
);
8956 if (UNLIMITED_POLY (re
))
8957 from_len
= gfc_class_len_get (tmp
);
8960 else if (re
->expr_type
!= EXPR_NULL
)
8961 /* Only when rhs is non-NULL use its declared type for vptr
8963 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8965 /* When the rhs is NULL use the vtab of lhs' declared type. */
8966 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8971 gfc_init_se (&se
, NULL
);
8972 se
.want_pointer
= 1;
8973 gfc_conv_expr (&se
, vptr_expr
);
8974 gfc_free_expr (vptr_expr
);
8975 gfc_add_block_to_block (block
, &se
.pre
);
8976 gcc_assert (se
.post
.head
== NULL_TREE
);
8978 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8981 if (to_len
!= NULL_TREE
)
8983 /* The _len component needs to be set. Figure how to get the
8984 value of the right-hand side. */
8985 if (from_len
== NULL_TREE
)
8987 if (rse
->string_length
!= NULL_TREE
)
8988 from_len
= rse
->string_length
;
8989 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8991 from_len
= gfc_get_expr_charlen (re
);
8992 gfc_init_se (&se
, NULL
);
8993 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8994 gfc_add_block_to_block (block
, &se
.pre
);
8995 gcc_assert (se
.post
.head
== NULL_TREE
);
8996 from_len
= gfc_evaluate_now (se
.expr
, block
);
8999 from_len
= build_zero_cst (gfc_charlen_type_node
);
9001 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9006 /* Return the _len trees only, when requested. */
9010 *from_lenp
= from_len
;
9015 /* Assign tokens for pointer components. */
9018 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9021 symbol_attribute lhs_attr
, rhs_attr
;
9022 tree tmp
, lhs_tok
, rhs_tok
;
9023 /* Flag to indicated component refs on the rhs. */
9026 lhs_attr
= gfc_caf_attr (expr1
);
9027 if (expr2
->expr_type
!= EXPR_NULL
)
9029 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9030 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9032 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9033 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9036 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9040 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9041 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9044 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9046 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9047 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9050 else if (lhs_attr
.codimension
)
9052 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9053 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9054 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9055 lhs_tok
, null_pointer_node
);
9056 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9061 /* Do everything that is needed for a CLASS function expr2. */
9064 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9065 gfc_expr
*expr1
, gfc_expr
*expr2
)
9067 tree expr1_vptr
= NULL_TREE
;
9070 gfc_conv_function_expr (rse
, expr2
);
9071 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9073 if (expr1
->ts
.type
!= BT_CLASS
)
9074 rse
->expr
= gfc_class_data_get (rse
->expr
);
9077 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9080 gfc_add_block_to_block (block
, &rse
->pre
);
9081 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9082 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9084 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9085 fold_convert (TREE_TYPE (expr1_vptr
),
9086 gfc_class_vptr_get (tmp
)));
9087 rse
->expr
= gfc_class_data_get (tmp
);
9095 gfc_trans_pointer_assign (gfc_code
* code
)
9097 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9101 /* Generate code for a pointer assignment. */
9104 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9111 tree expr1_vptr
= NULL_TREE
;
9112 bool scalar
, non_proc_ptr_assign
;
9115 gfc_start_block (&block
);
9117 gfc_init_se (&lse
, NULL
);
9119 /* Usually testing whether this is not a proc pointer assignment. */
9120 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9121 && expr2
->expr_type
== EXPR_VARIABLE
9122 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9124 /* Check whether the expression is a scalar or not; we cannot use
9125 expr1->rank as it can be nonzero for proc pointers. */
9126 ss
= gfc_walk_expr (expr1
);
9127 scalar
= ss
== gfc_ss_terminator
;
9129 gfc_free_ss_chain (ss
);
9131 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9132 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9134 gfc_add_data_component (expr2
);
9135 /* The following is required as gfc_add_data_component doesn't
9136 update ts.type if there is a tailing REF_ARRAY. */
9137 expr2
->ts
.type
= BT_DERIVED
;
9142 /* Scalar pointers. */
9143 lse
.want_pointer
= 1;
9144 gfc_conv_expr (&lse
, expr1
);
9145 gfc_init_se (&rse
, NULL
);
9146 rse
.want_pointer
= 1;
9147 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9148 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9150 gfc_conv_expr (&rse
, expr2
);
9152 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9154 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9156 lse
.expr
= gfc_class_data_get (lse
.expr
);
9159 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9160 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9161 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9164 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9165 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9166 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9169 gfc_add_block_to_block (&block
, &lse
.pre
);
9170 gfc_add_block_to_block (&block
, &rse
.pre
);
9172 /* Check character lengths if character expression. The test is only
9173 really added if -fbounds-check is enabled. Exclude deferred
9174 character length lefthand sides. */
9175 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9176 && !expr1
->ts
.deferred
9177 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9178 && !gfc_is_proc_ptr_comp (expr1
))
9180 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9181 gcc_assert (lse
.string_length
&& rse
.string_length
);
9182 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9183 lse
.string_length
, rse
.string_length
,
9187 /* The assignment to an deferred character length sets the string
9188 length to that of the rhs. */
9189 if (expr1
->ts
.deferred
)
9191 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9192 gfc_add_modify (&block
, lse
.string_length
,
9193 fold_convert (TREE_TYPE (lse
.string_length
),
9194 rse
.string_length
));
9195 else if (lse
.string_length
!= NULL
)
9196 gfc_add_modify (&block
, lse
.string_length
,
9197 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9200 gfc_add_modify (&block
, lse
.expr
,
9201 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9203 /* Also set the tokens for pointer components in derived typed
9205 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9206 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9208 gfc_add_block_to_block (&block
, &rse
.post
);
9209 gfc_add_block_to_block (&block
, &lse
.post
);
9216 tree strlen_rhs
= NULL_TREE
;
9218 /* Array pointer. Find the last reference on the LHS and if it is an
9219 array section ref, we're dealing with bounds remapping. In this case,
9220 set it to AR_FULL so that gfc_conv_expr_descriptor does
9221 not see it and process the bounds remapping afterwards explicitly. */
9222 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9223 if (!remap
->next
&& remap
->type
== REF_ARRAY
9224 && remap
->u
.ar
.type
== AR_SECTION
)
9226 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9228 gfc_init_se (&lse
, NULL
);
9230 lse
.descriptor_only
= 1;
9231 gfc_conv_expr_descriptor (&lse
, expr1
);
9232 strlen_lhs
= lse
.string_length
;
9235 if (expr2
->expr_type
== EXPR_NULL
)
9237 /* Just set the data pointer to null. */
9238 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9240 else if (rank_remap
)
9242 /* If we are rank-remapping, just get the RHS's descriptor and
9243 process this later on. */
9244 gfc_init_se (&rse
, NULL
);
9245 rse
.direct_byref
= 1;
9246 rse
.byref_noassign
= 1;
9248 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9249 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
9251 else if (expr2
->expr_type
== EXPR_FUNCTION
)
9253 tree bound
[GFC_MAX_DIMENSIONS
];
9256 for (i
= 0; i
< expr2
->rank
; i
++)
9257 bound
[i
] = NULL_TREE
;
9258 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
9259 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
9261 GFC_ARRAY_POINTER_CONT
, false);
9262 tmp
= gfc_create_var (tmp
, "ptrtemp");
9263 rse
.descriptor_only
= 0;
9265 rse
.direct_byref
= 1;
9266 gfc_conv_expr_descriptor (&rse
, expr2
);
9267 strlen_rhs
= rse
.string_length
;
9272 gfc_conv_expr_descriptor (&rse
, expr2
);
9273 strlen_rhs
= rse
.string_length
;
9274 if (expr1
->ts
.type
== BT_CLASS
)
9275 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9280 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9282 /* Assign directly to the LHS's descriptor. */
9283 lse
.descriptor_only
= 0;
9284 lse
.direct_byref
= 1;
9285 gfc_conv_expr_descriptor (&lse
, expr2
);
9286 strlen_rhs
= lse
.string_length
;
9288 if (expr1
->ts
.type
== BT_CLASS
)
9290 rse
.expr
= NULL_TREE
;
9291 rse
.string_length
= NULL_TREE
;
9292 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
9298 /* If the target is not a whole array, use the target array
9299 reference for remap. */
9300 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
9301 if (remap
->type
== REF_ARRAY
9302 && remap
->u
.ar
.type
== AR_FULL
9307 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9309 gfc_init_se (&rse
, NULL
);
9310 rse
.want_pointer
= 1;
9311 gfc_conv_function_expr (&rse
, expr2
);
9312 if (expr1
->ts
.type
!= BT_CLASS
)
9314 rse
.expr
= gfc_class_data_get (rse
.expr
);
9315 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9316 /* Set the lhs span. */
9317 tmp
= TREE_TYPE (rse
.expr
);
9318 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9319 tmp
= fold_convert (gfc_array_index_type
, tmp
);
9320 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
9324 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
9327 gfc_add_block_to_block (&block
, &rse
.pre
);
9328 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
9329 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
9331 gfc_add_modify (&lse
.pre
, expr1_vptr
,
9332 fold_convert (TREE_TYPE (expr1_vptr
),
9333 gfc_class_vptr_get (tmp
)));
9334 rse
.expr
= gfc_class_data_get (tmp
);
9335 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
9340 /* Assign to a temporary descriptor and then copy that
9341 temporary to the pointer. */
9342 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
9343 lse
.descriptor_only
= 0;
9345 lse
.direct_byref
= 1;
9346 gfc_conv_expr_descriptor (&lse
, expr2
);
9347 strlen_rhs
= lse
.string_length
;
9348 gfc_add_modify (&lse
.pre
, desc
, tmp
);
9351 gfc_add_block_to_block (&block
, &lse
.pre
);
9353 gfc_add_block_to_block (&block
, &rse
.pre
);
9355 /* If we do bounds remapping, update LHS descriptor accordingly. */
9359 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
9363 /* Do rank remapping. We already have the RHS's descriptor
9364 converted in rse and now have to build the correct LHS
9365 descriptor for it. */
9367 tree dtype
, data
, span
;
9369 tree lbound
, ubound
;
9372 dtype
= gfc_conv_descriptor_dtype (desc
);
9373 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
9374 gfc_add_modify (&block
, dtype
, tmp
);
9376 /* Copy data pointer. */
9377 data
= gfc_conv_descriptor_data_get (rse
.expr
);
9378 gfc_conv_descriptor_data_set (&block
, desc
, data
);
9380 /* Copy the span. */
9381 if (TREE_CODE (rse
.expr
) == VAR_DECL
9382 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
9383 span
= gfc_conv_descriptor_span_get (rse
.expr
);
9386 tmp
= TREE_TYPE (rse
.expr
);
9387 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
9388 span
= fold_convert (gfc_array_index_type
, tmp
);
9390 gfc_conv_descriptor_span_set (&block
, desc
, span
);
9392 /* Copy offset but adjust it such that it would correspond
9393 to a lbound of zero. */
9394 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
9395 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
9397 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9399 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
9401 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9402 gfc_array_index_type
, stride
, lbound
);
9403 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9404 gfc_array_index_type
, offs
, tmp
);
9406 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9408 /* Set the bounds as declared for the LHS and calculate strides as
9409 well as another offset update accordingly. */
9410 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9412 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9417 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9419 /* Convert declared bounds. */
9420 gfc_init_se (&lower_se
, NULL
);
9421 gfc_init_se (&upper_se
, NULL
);
9422 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9423 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9425 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9426 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9428 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9429 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9431 lbound
= gfc_evaluate_now (lbound
, &block
);
9432 ubound
= gfc_evaluate_now (ubound
, &block
);
9434 gfc_add_block_to_block (&block
, &lower_se
.post
);
9435 gfc_add_block_to_block (&block
, &upper_se
.post
);
9437 /* Set bounds in descriptor. */
9438 gfc_conv_descriptor_lbound_set (&block
, desc
,
9439 gfc_rank_cst
[dim
], lbound
);
9440 gfc_conv_descriptor_ubound_set (&block
, desc
,
9441 gfc_rank_cst
[dim
], ubound
);
9444 stride
= gfc_evaluate_now (stride
, &block
);
9445 gfc_conv_descriptor_stride_set (&block
, desc
,
9446 gfc_rank_cst
[dim
], stride
);
9448 /* Update offset. */
9449 offs
= gfc_conv_descriptor_offset_get (desc
);
9450 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9451 gfc_array_index_type
, lbound
, stride
);
9452 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9453 gfc_array_index_type
, offs
, tmp
);
9454 offs
= gfc_evaluate_now (offs
, &block
);
9455 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9457 /* Update stride. */
9458 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9459 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9460 gfc_array_index_type
, stride
, tmp
);
9465 /* Bounds remapping. Just shift the lower bounds. */
9467 gcc_assert (expr1
->rank
== expr2
->rank
);
9469 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9473 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9474 gfc_init_se (&lbound_se
, NULL
);
9475 if (remap
->u
.ar
.start
[dim
])
9477 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9478 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9481 /* This remap arises from a target that is not a whole
9482 array. The start expressions will be NULL but we need
9483 the lbounds to be one. */
9484 lbound_se
.expr
= gfc_index_one_node
;
9485 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9486 dim
, lbound_se
.expr
);
9487 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9492 /* If rank remapping was done, check with -fcheck=bounds that
9493 the target is at least as large as the pointer. */
9494 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9500 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9501 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9503 lsize
= gfc_evaluate_now (lsize
, &block
);
9504 rsize
= gfc_evaluate_now (rsize
, &block
);
9505 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9508 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9509 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9513 if (expr1
->ts
.type
== BT_CHARACTER
9514 && expr1
->symtree
->n
.sym
->ts
.deferred
9515 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9516 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9518 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9519 if (expr2
->expr_type
!= EXPR_NULL
)
9520 gfc_add_modify (&block
, tmp
,
9521 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9523 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9526 /* Check string lengths if applicable. The check is only really added
9527 to the output code if -fbounds-check is enabled. */
9528 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9530 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9531 gcc_assert (strlen_lhs
&& strlen_rhs
);
9532 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9533 strlen_lhs
, strlen_rhs
, &block
);
9536 gfc_add_block_to_block (&block
, &lse
.post
);
9538 gfc_add_block_to_block (&block
, &rse
.post
);
9541 return gfc_finish_block (&block
);
9545 /* Makes sure se is suitable for passing as a function string parameter. */
9546 /* TODO: Need to check all callers of this function. It may be abused. */
9549 gfc_conv_string_parameter (gfc_se
* se
)
9553 if (TREE_CODE (se
->expr
) == STRING_CST
)
9555 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9556 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9560 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9562 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9564 type
= TREE_TYPE (se
->expr
);
9565 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9569 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9571 type
= build_pointer_type (type
);
9572 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9576 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9580 /* Generate code for assignment of scalar variables. Includes character
9581 strings and derived types with allocatable components.
9582 If you know that the LHS has no allocations, set dealloc to false.
9584 DEEP_COPY has no effect if the typespec TS is not a derived type with
9585 allocatable components. Otherwise, if it is set, an explicit copy of each
9586 allocatable component is made. This is necessary as a simple copy of the
9587 whole object would copy array descriptors as is, so that the lhs's
9588 allocatable components would point to the rhs's after the assignment.
9589 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9590 necessary if the rhs is a non-pointer function, as the allocatable components
9591 are not accessible by other means than the function's result after the
9592 function has returned. It is even more subtle when temporaries are involved,
9593 as the two following examples show:
9594 1. When we evaluate an array constructor, a temporary is created. Thus
9595 there is theoretically no alias possible. However, no deep copy is
9596 made for this temporary, so that if the constructor is made of one or
9597 more variable with allocatable components, those components still point
9598 to the variable's: DEEP_COPY should be set for the assignment from the
9599 temporary to the lhs in that case.
9600 2. When assigning a scalar to an array, we evaluate the scalar value out
9601 of the loop, store it into a temporary variable, and assign from that.
9602 In that case, deep copying when assigning to the temporary would be a
9603 waste of resources; however deep copies should happen when assigning from
9604 the temporary to each array element: again DEEP_COPY should be set for
9605 the assignment from the temporary to the lhs. */
9608 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9609 bool deep_copy
, bool dealloc
, bool in_coarray
)
9615 gfc_init_block (&block
);
9617 if (ts
.type
== BT_CHARACTER
)
9622 if (lse
->string_length
!= NULL_TREE
)
9624 gfc_conv_string_parameter (lse
);
9625 gfc_add_block_to_block (&block
, &lse
->pre
);
9626 llen
= lse
->string_length
;
9629 if (rse
->string_length
!= NULL_TREE
)
9631 gfc_conv_string_parameter (rse
);
9632 gfc_add_block_to_block (&block
, &rse
->pre
);
9633 rlen
= rse
->string_length
;
9636 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9637 rse
->expr
, ts
.kind
);
9639 else if (gfc_bt_struct (ts
.type
)
9640 && (ts
.u
.derived
->attr
.alloc_comp
9641 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9643 tree tmp_var
= NULL_TREE
;
9646 /* Are the rhs and the lhs the same? */
9649 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9650 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9651 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9652 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9655 /* Deallocate the lhs allocated components as long as it is not
9656 the same as the rhs. This must be done following the assignment
9657 to prevent deallocating data that could be used in the rhs
9661 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9662 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9664 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9666 gfc_add_expr_to_block (&lse
->post
, tmp
);
9669 gfc_add_block_to_block (&block
, &rse
->pre
);
9670 gfc_add_block_to_block (&block
, &lse
->pre
);
9672 gfc_add_modify (&block
, lse
->expr
,
9673 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9675 /* Restore pointer address of coarray components. */
9676 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9678 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9679 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9681 gfc_add_expr_to_block (&block
, tmp
);
9684 /* Do a deep copy if the rhs is a variable, if it is not the
9688 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9689 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9690 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9692 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9694 gfc_add_expr_to_block (&block
, tmp
);
9697 else if (gfc_bt_struct (ts
.type
))
9699 gfc_add_block_to_block (&block
, &lse
->pre
);
9700 gfc_add_block_to_block (&block
, &rse
->pre
);
9701 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9702 TREE_TYPE (lse
->expr
), rse
->expr
);
9703 gfc_add_modify (&block
, lse
->expr
, tmp
);
9705 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
9706 else if (ts
.type
== BT_CLASS
9707 && !trans_scalar_class_assign (&block
, lse
, rse
))
9709 gfc_add_block_to_block (&block
, &lse
->pre
);
9710 gfc_add_block_to_block (&block
, &rse
->pre
);
9711 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
9712 for the lhs which ensures that class data rhs cast as a string assigns
9714 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9715 TREE_TYPE (rse
->expr
), lse
->expr
);
9716 gfc_add_modify (&block
, tmp
, rse
->expr
);
9718 else if (ts
.type
!= BT_CLASS
)
9720 gfc_add_block_to_block (&block
, &lse
->pre
);
9721 gfc_add_block_to_block (&block
, &rse
->pre
);
9723 gfc_add_modify (&block
, lse
->expr
,
9724 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9727 gfc_add_block_to_block (&block
, &lse
->post
);
9728 gfc_add_block_to_block (&block
, &rse
->post
);
9730 return gfc_finish_block (&block
);
9734 /* There are quite a lot of restrictions on the optimisation in using an
9735 array function assign without a temporary. */
9738 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9741 bool seen_array_ref
;
9743 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9745 /* Play it safe with class functions assigned to a derived type. */
9746 if (gfc_is_class_array_function (expr2
)
9747 && expr1
->ts
.type
== BT_DERIVED
)
9750 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9751 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9754 /* Elemental functions are scalarized so that they don't need a
9755 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9756 they would need special treatment in gfc_trans_arrayfunc_assign. */
9757 if (expr2
->value
.function
.esym
!= NULL
9758 && expr2
->value
.function
.esym
->attr
.elemental
)
9761 /* Need a temporary if rhs is not FULL or a contiguous section. */
9762 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9765 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9766 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9769 /* Functions returning pointers or allocatables need temporaries. */
9770 c
= expr2
->value
.function
.esym
9771 ? (expr2
->value
.function
.esym
->attr
.pointer
9772 || expr2
->value
.function
.esym
->attr
.allocatable
)
9773 : (expr2
->symtree
->n
.sym
->attr
.pointer
9774 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9778 /* Character array functions need temporaries unless the
9779 character lengths are the same. */
9780 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9782 if (expr1
->ts
.u
.cl
->length
== NULL
9783 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9786 if (expr2
->ts
.u
.cl
->length
== NULL
9787 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9790 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9791 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9795 /* Check that no LHS component references appear during an array
9796 reference. This is needed because we do not have the means to
9797 span any arbitrary stride with an array descriptor. This check
9798 is not needed for the rhs because the function result has to be
9800 seen_array_ref
= false;
9801 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9803 if (ref
->type
== REF_ARRAY
)
9804 seen_array_ref
= true;
9805 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9809 /* Check for a dependency. */
9810 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9811 expr2
->value
.function
.esym
,
9812 expr2
->value
.function
.actual
,
9816 /* If we have reached here with an intrinsic function, we do not
9817 need a temporary except in the particular case that reallocation
9818 on assignment is active and the lhs is allocatable and a target. */
9819 if (expr2
->value
.function
.isym
)
9820 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9822 /* If the LHS is a dummy, we need a temporary if it is not
9824 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9827 /* If the lhs has been host_associated, is in common, a pointer or is
9828 a target and the function is not using a RESULT variable, aliasing
9829 can occur and a temporary is needed. */
9830 if ((sym
->attr
.host_assoc
9831 || sym
->attr
.in_common
9832 || sym
->attr
.pointer
9833 || sym
->attr
.cray_pointee
9834 || sym
->attr
.target
)
9835 && expr2
->symtree
!= NULL
9836 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9839 /* A PURE function can unconditionally be called without a temporary. */
9840 if (expr2
->value
.function
.esym
!= NULL
9841 && expr2
->value
.function
.esym
->attr
.pure
)
9844 /* Implicit_pure functions are those which could legally be declared
9846 if (expr2
->value
.function
.esym
!= NULL
9847 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9850 if (!sym
->attr
.use_assoc
9851 && !sym
->attr
.in_common
9852 && !sym
->attr
.pointer
9853 && !sym
->attr
.target
9854 && !sym
->attr
.cray_pointee
9855 && expr2
->value
.function
.esym
)
9857 /* A temporary is not needed if the function is not contained and
9858 the variable is local or host associated and not a pointer or
9860 if (!expr2
->value
.function
.esym
->attr
.contained
)
9863 /* A temporary is not needed if the lhs has never been host
9864 associated and the procedure is contained. */
9865 else if (!sym
->attr
.host_assoc
)
9868 /* A temporary is not needed if the variable is local and not
9869 a pointer, a target or a result. */
9871 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9875 /* Default to temporary use. */
9880 /* Provide the loop info so that the lhs descriptor can be built for
9881 reallocatable assignments from extrinsic function calls. */
9884 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9887 /* Signal that the function call should not be made by
9888 gfc_conv_loop_setup. */
9889 se
->ss
->is_alloc_lhs
= 1;
9890 gfc_init_loopinfo (loop
);
9891 gfc_add_ss_to_loop (loop
, *ss
);
9892 gfc_add_ss_to_loop (loop
, se
->ss
);
9893 gfc_conv_ss_startstride (loop
);
9894 gfc_conv_loop_setup (loop
, where
);
9895 gfc_copy_loopinfo_to_se (se
, loop
);
9896 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9897 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9898 se
->ss
->is_alloc_lhs
= 0;
9902 /* For assignment to a reallocatable lhs from intrinsic functions,
9903 replace the se.expr (ie. the result) with a temporary descriptor.
9904 Null the data field so that the library allocates space for the
9905 result. Free the data of the original descriptor after the function,
9906 in case it appears in an argument expression and transfer the
9907 result to the original descriptor. */
9910 fcncall_realloc_result (gfc_se
*se
, int rank
)
9919 /* Use the allocation done by the library. Substitute the lhs
9920 descriptor with a copy, whose data field is nulled.*/
9921 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9922 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9923 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9925 /* Unallocated, the descriptor does not have a dtype. */
9926 tmp
= gfc_conv_descriptor_dtype (desc
);
9927 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9929 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9930 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9931 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9933 /* Free the lhs after the function call and copy the result data to
9934 the lhs descriptor. */
9935 tmp
= gfc_conv_descriptor_data_get (desc
);
9936 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9937 logical_type_node
, tmp
,
9938 build_int_cst (TREE_TYPE (tmp
), 0));
9939 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9940 tmp
= gfc_call_free (tmp
);
9941 gfc_add_expr_to_block (&se
->post
, tmp
);
9943 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9944 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9946 /* Check that the shapes are the same between lhs and expression. */
9947 for (n
= 0 ; n
< rank
; n
++)
9950 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9951 tmp1
= gfc_conv_descriptor_lbound_get (res_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 (desc
, gfc_rank_cst
[n
]);
9955 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9956 gfc_array_index_type
, tmp
, tmp1
);
9957 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9958 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9959 gfc_array_index_type
, tmp
, tmp1
);
9960 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9961 logical_type_node
, tmp
,
9962 gfc_index_zero_node
);
9963 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9964 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9965 logical_type_node
, tmp
,
9969 /* 'zero_cond' being true is equal to lhs not being allocated or the
9970 shapes being different. */
9971 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9973 /* Now reset the bounds returned from the function call to bounds based
9974 on the lhs lbounds, except where the lhs is not allocated or the shapes
9975 of 'variable and 'expr' are different. Set the offset accordingly. */
9976 offset
= gfc_index_zero_node
;
9977 for (n
= 0 ; n
< rank
; n
++)
9981 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9982 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9983 gfc_array_index_type
, zero_cond
,
9984 gfc_index_one_node
, lbound
);
9985 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9987 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9988 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9989 gfc_array_index_type
, tmp
, lbound
);
9990 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9991 gfc_rank_cst
[n
], lbound
);
9992 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9993 gfc_rank_cst
[n
], tmp
);
9995 /* Set stride and accumulate the offset. */
9996 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9997 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9998 gfc_rank_cst
[n
], tmp
);
9999 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10000 gfc_array_index_type
, lbound
, tmp
);
10001 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10002 gfc_array_index_type
, offset
, tmp
);
10003 offset
= gfc_evaluate_now (offset
, &se
->post
);
10006 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10011 /* Try to translate array(:) = func (...), where func is a transformational
10012 array function, without using a temporary. Returns NULL if this isn't the
10016 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10020 gfc_component
*comp
= NULL
;
10023 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10026 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10028 comp
= gfc_get_proc_ptr_comp (expr2
);
10030 if (!(expr2
->value
.function
.isym
10031 || (comp
&& comp
->attr
.dimension
)
10032 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10033 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10036 gfc_init_se (&se
, NULL
);
10037 gfc_start_block (&se
.pre
);
10038 se
.want_pointer
= 1;
10040 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10042 if (expr1
->ts
.type
== BT_DERIVED
10043 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10046 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10048 gfc_add_expr_to_block (&se
.pre
, tmp
);
10051 se
.direct_byref
= 1;
10052 se
.ss
= gfc_walk_expr (expr2
);
10053 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10055 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10056 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10057 Clearly, this cannot be done for an allocatable function result, since
10058 the shape of the result is unknown and, in any case, the function must
10059 correctly take care of the reallocation internally. For intrinsic
10060 calls, the array data is freed and the library takes care of allocation.
10061 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10063 if (flag_realloc_lhs
10064 && gfc_is_reallocatable_lhs (expr1
)
10065 && !gfc_expr_attr (expr1
).codimension
10066 && !gfc_is_coindexed (expr1
)
10067 && !(expr2
->value
.function
.esym
10068 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10070 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10072 if (!expr2
->value
.function
.isym
)
10074 ss
= gfc_walk_expr (expr1
);
10075 gcc_assert (ss
!= gfc_ss_terminator
);
10077 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10078 ss
->is_alloc_lhs
= 1;
10081 fcncall_realloc_result (&se
, expr1
->rank
);
10084 gfc_conv_function_expr (&se
, expr2
);
10085 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10088 gfc_cleanup_loop (&loop
);
10090 gfc_free_ss_chain (se
.ss
);
10092 return gfc_finish_block (&se
.pre
);
10096 /* Try to efficiently translate array(:) = 0. Return NULL if this
10100 gfc_trans_zero_assign (gfc_expr
* expr
)
10102 tree dest
, len
, type
;
10106 sym
= expr
->symtree
->n
.sym
;
10107 dest
= gfc_get_symbol_decl (sym
);
10109 type
= TREE_TYPE (dest
);
10110 if (POINTER_TYPE_P (type
))
10111 type
= TREE_TYPE (type
);
10112 if (!GFC_ARRAY_TYPE_P (type
))
10115 /* Determine the length of the array. */
10116 len
= GFC_TYPE_ARRAY_SIZE (type
);
10117 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10120 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10121 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10122 fold_convert (gfc_array_index_type
, tmp
));
10124 /* If we are zeroing a local array avoid taking its address by emitting
10126 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10127 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10128 dest
, build_constructor (TREE_TYPE (dest
),
10131 /* Convert arguments to the correct types. */
10132 dest
= fold_convert (pvoid_type_node
, dest
);
10133 len
= fold_convert (size_type_node
, len
);
10135 /* Construct call to __builtin_memset. */
10136 tmp
= build_call_expr_loc (input_location
,
10137 builtin_decl_explicit (BUILT_IN_MEMSET
),
10138 3, dest
, integer_zero_node
, len
);
10139 return fold_convert (void_type_node
, tmp
);
10143 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10144 that constructs the call to __builtin_memcpy. */
10147 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10151 /* Convert arguments to the correct types. */
10152 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10153 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10155 dst
= fold_convert (pvoid_type_node
, dst
);
10157 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10158 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10160 src
= fold_convert (pvoid_type_node
, src
);
10162 len
= fold_convert (size_type_node
, len
);
10164 /* Construct call to __builtin_memcpy. */
10165 tmp
= build_call_expr_loc (input_location
,
10166 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10168 return fold_convert (void_type_node
, tmp
);
10172 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10173 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10174 source/rhs, both are gfc_full_array_ref_p which have been checked for
10178 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10180 tree dst
, dlen
, dtype
;
10181 tree src
, slen
, stype
;
10184 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10185 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10187 dtype
= TREE_TYPE (dst
);
10188 if (POINTER_TYPE_P (dtype
))
10189 dtype
= TREE_TYPE (dtype
);
10190 stype
= TREE_TYPE (src
);
10191 if (POINTER_TYPE_P (stype
))
10192 stype
= TREE_TYPE (stype
);
10194 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10197 /* Determine the lengths of the arrays. */
10198 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10199 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10201 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10202 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10203 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10205 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10206 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10208 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10209 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10210 slen
, fold_convert (gfc_array_index_type
, tmp
));
10212 /* Sanity check that they are the same. This should always be
10213 the case, as we should already have checked for conformance. */
10214 if (!tree_int_cst_equal (slen
, dlen
))
10217 return gfc_build_memcpy_call (dst
, src
, dlen
);
10221 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10222 this can't be done. EXPR1 is the destination/lhs for which
10223 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10226 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10228 unsigned HOST_WIDE_INT nelem
;
10234 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
10238 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10239 dtype
= TREE_TYPE (dst
);
10240 if (POINTER_TYPE_P (dtype
))
10241 dtype
= TREE_TYPE (dtype
);
10242 if (!GFC_ARRAY_TYPE_P (dtype
))
10245 /* Determine the lengths of the array. */
10246 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
10247 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10250 /* Confirm that the constructor is the same size. */
10251 if (compare_tree_int (len
, nelem
) != 0)
10254 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10255 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10256 fold_convert (gfc_array_index_type
, tmp
));
10258 stype
= gfc_typenode_for_spec (&expr2
->ts
);
10259 src
= gfc_build_constant_array_constructor (expr2
, stype
);
10261 stype
= TREE_TYPE (src
);
10262 if (POINTER_TYPE_P (stype
))
10263 stype
= TREE_TYPE (stype
);
10265 return gfc_build_memcpy_call (dst
, src
, len
);
10269 /* Tells whether the expression is to be treated as a variable reference. */
10272 gfc_expr_is_variable (gfc_expr
*expr
)
10275 gfc_component
*comp
;
10276 gfc_symbol
*func_ifc
;
10278 if (expr
->expr_type
== EXPR_VARIABLE
)
10281 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
10284 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
10285 return gfc_expr_is_variable (arg
);
10288 /* A data-pointer-returning function should be considered as a variable
10290 if (expr
->expr_type
== EXPR_FUNCTION
10291 && expr
->ref
== NULL
)
10293 if (expr
->value
.function
.isym
!= NULL
)
10296 if (expr
->value
.function
.esym
!= NULL
)
10298 func_ifc
= expr
->value
.function
.esym
;
10303 gcc_assert (expr
->symtree
);
10304 func_ifc
= expr
->symtree
->n
.sym
;
10308 gcc_unreachable ();
10311 comp
= gfc_get_proc_ptr_comp (expr
);
10312 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
10315 func_ifc
= comp
->ts
.interface
;
10319 if (expr
->expr_type
== EXPR_COMPCALL
)
10321 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
10322 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
10329 gcc_assert (func_ifc
->attr
.function
10330 && func_ifc
->result
!= NULL
);
10331 return func_ifc
->result
->attr
.pointer
;
10335 /* Is the lhs OK for automatic reallocation? */
10338 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
10342 /* An allocatable variable with no reference. */
10343 if (expr
->symtree
->n
.sym
->attr
.allocatable
10347 /* All that can be left are allocatable components. However, we do
10348 not check for allocatable components here because the expression
10349 could be an allocatable component of a pointer component. */
10350 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
10351 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
10354 /* Find an allocatable component ref last. */
10355 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
10356 if (ref
->type
== REF_COMPONENT
10358 && ref
->u
.c
.component
->attr
.allocatable
)
10365 /* Allocate or reallocate scalar lhs, as necessary. */
10368 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
10369 tree string_length
,
10377 tree size_in_bytes
;
10383 if (!expr1
|| expr1
->rank
)
10386 if (!expr2
|| expr2
->rank
)
10389 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10390 if (ref
->type
== REF_SUBSTRING
)
10393 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
10395 /* Since this is a scalar lhs, we can afford to do this. That is,
10396 there is no risk of side effects being repeated. */
10397 gfc_init_se (&lse
, NULL
);
10398 lse
.want_pointer
= 1;
10399 gfc_conv_expr (&lse
, expr1
);
10401 jump_label1
= gfc_build_label_decl (NULL_TREE
);
10402 jump_label2
= gfc_build_label_decl (NULL_TREE
);
10404 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10405 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
10406 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
10408 tmp
= build3_v (COND_EXPR
, cond
,
10409 build1_v (GOTO_EXPR
, jump_label1
),
10410 build_empty_stmt (input_location
));
10411 gfc_add_expr_to_block (block
, tmp
);
10413 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10415 /* Use the rhs string length and the lhs element size. */
10416 size
= string_length
;
10417 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10418 tmp
= TYPE_SIZE_UNIT (tmp
);
10419 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10420 TREE_TYPE (tmp
), tmp
,
10421 fold_convert (TREE_TYPE (tmp
), size
));
10425 /* Otherwise use the length in bytes of the rhs. */
10426 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10427 size_in_bytes
= size
;
10430 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10431 size_in_bytes
, size_one_node
);
10433 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10435 tree caf_decl
, token
;
10437 symbol_attribute attr
;
10439 gfc_clear_attr (&attr
);
10440 gfc_init_se (&caf_se
, NULL
);
10442 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10443 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10445 gfc_add_block_to_block (block
, &caf_se
.pre
);
10446 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10447 gfc_build_addr_expr (NULL_TREE
, token
),
10448 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10451 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10453 tmp
= build_call_expr_loc (input_location
,
10454 builtin_decl_explicit (BUILT_IN_CALLOC
),
10455 2, build_one_cst (size_type_node
),
10457 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10458 gfc_add_modify (block
, lse
.expr
, tmp
);
10462 tmp
= build_call_expr_loc (input_location
,
10463 builtin_decl_explicit (BUILT_IN_MALLOC
),
10465 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10466 gfc_add_modify (block
, lse
.expr
, tmp
);
10469 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10471 /* Deferred characters need checking for lhs and rhs string
10472 length. Other deferred parameter variables will have to
10474 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10475 gfc_add_expr_to_block (block
, tmp
);
10477 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10478 gfc_add_expr_to_block (block
, tmp
);
10480 /* For a deferred length character, reallocate if lengths of lhs and
10481 rhs are different. */
10482 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10484 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10486 fold_convert (TREE_TYPE (lse
.string_length
),
10488 /* Jump past the realloc if the lengths are the same. */
10489 tmp
= build3_v (COND_EXPR
, cond
,
10490 build1_v (GOTO_EXPR
, jump_label2
),
10491 build_empty_stmt (input_location
));
10492 gfc_add_expr_to_block (block
, tmp
);
10493 tmp
= build_call_expr_loc (input_location
,
10494 builtin_decl_explicit (BUILT_IN_REALLOC
),
10495 2, fold_convert (pvoid_type_node
, lse
.expr
),
10497 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10498 gfc_add_modify (block
, lse
.expr
, tmp
);
10499 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10500 gfc_add_expr_to_block (block
, tmp
);
10502 /* Update the lhs character length. */
10503 size
= string_length
;
10504 gfc_add_modify (block
, lse
.string_length
,
10505 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10509 /* Check for assignments of the type
10513 to make sure we do not check for reallocation unneccessarily. */
10517 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10519 gfc_actual_arglist
*a
;
10522 switch (expr2
->expr_type
)
10524 case EXPR_VARIABLE
:
10525 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10527 case EXPR_FUNCTION
:
10528 if (expr2
->value
.function
.esym
10529 && expr2
->value
.function
.esym
->attr
.elemental
)
10531 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10534 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10539 else if (expr2
->value
.function
.isym
10540 && expr2
->value
.function
.isym
->elemental
)
10542 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10545 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10554 switch (expr2
->value
.op
.op
)
10556 case INTRINSIC_NOT
:
10557 case INTRINSIC_UPLUS
:
10558 case INTRINSIC_UMINUS
:
10559 case INTRINSIC_PARENTHESES
:
10560 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10562 case INTRINSIC_PLUS
:
10563 case INTRINSIC_MINUS
:
10564 case INTRINSIC_TIMES
:
10565 case INTRINSIC_DIVIDE
:
10566 case INTRINSIC_POWER
:
10567 case INTRINSIC_AND
:
10569 case INTRINSIC_EQV
:
10570 case INTRINSIC_NEQV
:
10577 case INTRINSIC_EQ_OS
:
10578 case INTRINSIC_NE_OS
:
10579 case INTRINSIC_GT_OS
:
10580 case INTRINSIC_GE_OS
:
10581 case INTRINSIC_LT_OS
:
10582 case INTRINSIC_LE_OS
:
10584 e1
= expr2
->value
.op
.op1
;
10585 e2
= expr2
->value
.op
.op2
;
10587 if (e1
->rank
== 0 && e2
->rank
> 0)
10588 return is_runtime_conformable (expr1
, e2
);
10589 else if (e1
->rank
> 0 && e2
->rank
== 0)
10590 return is_runtime_conformable (expr1
, e1
);
10591 else if (e1
->rank
> 0 && e2
->rank
> 0)
10592 return is_runtime_conformable (expr1
, e1
)
10593 && is_runtime_conformable (expr1
, e2
);
10611 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10612 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10613 bool class_realloc
)
10615 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
, old_vptr
;
10616 vec
<tree
, va_gc
> *args
= NULL
;
10618 /* Store the old vptr so that dynamic types can be compared for
10619 reallocation to occur or not. */
10623 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
10624 tmp
= gfc_get_class_from_expr (tmp
);
10627 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10630 /* Generate (re)allocation of the lhs. */
10633 stmtblock_t alloc
, re_alloc
;
10634 tree class_han
, re
, size
;
10636 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
10637 old_vptr
= gfc_evaluate_now (gfc_class_vptr_get (tmp
), block
);
10639 old_vptr
= build_int_cst (TREE_TYPE (vptr
), 0);
10641 size
= gfc_vptr_size_get (vptr
);
10642 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10643 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10645 /* Allocate block. */
10646 gfc_init_block (&alloc
);
10647 gfc_allocate_using_malloc (&alloc
, class_han
, size
, NULL_TREE
);
10649 /* Reallocate if dynamic types are different. */
10650 gfc_init_block (&re_alloc
);
10651 re
= build_call_expr_loc (input_location
,
10652 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
10653 fold_convert (pvoid_type_node
, class_han
),
10655 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10656 logical_type_node
, vptr
, old_vptr
);
10657 re
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10658 tmp
, re
, build_empty_stmt (input_location
));
10659 gfc_add_expr_to_block (&re_alloc
, re
);
10661 /* Allocate if _data is NULL, reallocate otherwise. */
10662 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10663 logical_type_node
, class_han
,
10664 build_int_cst (prvoid_type_node
, 0));
10665 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10667 PRED_FORTRAN_FAIL_ALLOC
),
10668 gfc_finish_block (&alloc
),
10669 gfc_finish_block (&re_alloc
));
10670 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10673 fcn
= gfc_vptr_copy_get (vptr
);
10675 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10676 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10679 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10680 || INDIRECT_REF_P (tmp
)
10681 || (rhs
->ts
.type
== BT_DERIVED
10682 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10683 && !rhs
->ts
.u
.derived
->attr
.pointer
10684 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10685 || (UNLIMITED_POLY (rhs
)
10686 && !CLASS_DATA (rhs
)->attr
.pointer
10687 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10688 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10690 vec_safe_push (args
, tmp
);
10691 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10692 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10693 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10694 || INDIRECT_REF_P (tmp
)
10695 || (lhs
->ts
.type
== BT_DERIVED
10696 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10697 && !lhs
->ts
.u
.derived
->attr
.pointer
10698 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10699 || (UNLIMITED_POLY (lhs
)
10700 && !CLASS_DATA (lhs
)->attr
.pointer
10701 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10702 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10704 vec_safe_push (args
, tmp
);
10706 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10708 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10711 vec_safe_push (args
, from_len
);
10712 vec_safe_push (args
, to_len
);
10713 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10715 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10716 logical_type_node
, from_len
,
10717 build_zero_cst (TREE_TYPE (from_len
)));
10718 return fold_build3_loc (input_location
, COND_EXPR
,
10719 void_type_node
, tmp
,
10727 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10728 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10729 stmtblock_t tblock
;
10730 gfc_init_block (&tblock
);
10731 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10732 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10733 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10734 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10735 /* When coming from a ptr_copy lhs and rhs are swapped. */
10736 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10737 fold_convert (TREE_TYPE (rhst
), tmp
));
10738 return gfc_finish_block (&tblock
);
10742 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10743 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10744 init_flag indicates initialization expressions and dealloc that no
10745 deallocate prior assignment is needed (if in doubt, set true).
10746 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10747 routine instead of a pointer assignment. Alias resolution is only done,
10748 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10749 where it is known, that newly allocated memory on the lhs can never be
10750 an alias of the rhs. */
10753 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10754 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10759 gfc_ss
*lss_section
;
10766 bool scalar_to_array
;
10767 tree string_length
;
10769 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10770 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10771 bool is_poly_assign
;
10774 /* Assignment of the form lhs = rhs. */
10775 gfc_start_block (&block
);
10777 gfc_init_se (&lse
, NULL
);
10778 gfc_init_se (&rse
, NULL
);
10780 /* Walk the lhs. */
10781 lss
= gfc_walk_expr (expr1
);
10782 if (gfc_is_reallocatable_lhs (expr1
))
10784 lss
->no_bounds_check
= 1;
10785 if (!(expr2
->expr_type
== EXPR_FUNCTION
10786 && expr2
->value
.function
.isym
!= NULL
10787 && !(expr2
->value
.function
.isym
->elemental
10788 || expr2
->value
.function
.isym
->conversion
)))
10789 lss
->is_alloc_lhs
= 1;
10792 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10796 if ((expr1
->ts
.type
== BT_DERIVED
)
10797 && (gfc_is_class_array_function (expr2
)
10798 || gfc_is_alloc_class_scalar_function (expr2
)))
10799 expr2
->must_finalize
= 1;
10801 /* Checking whether a class assignment is desired is quite complicated and
10802 needed at two locations, so do it once only before the information is
10804 lhs_attr
= gfc_expr_attr (expr1
);
10805 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10806 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10807 && (expr1
->ts
.type
== BT_CLASS
10808 || gfc_is_class_array_ref (expr1
, NULL
)
10809 || gfc_is_class_scalar_expr (expr1
)
10810 || gfc_is_class_array_ref (expr2
, NULL
)
10811 || gfc_is_class_scalar_expr (expr2
))
10812 && lhs_attr
.flavor
!= FL_PROCEDURE
;
10814 realloc_flag
= flag_realloc_lhs
10815 && gfc_is_reallocatable_lhs (expr1
)
10817 && !is_runtime_conformable (expr1
, expr2
);
10819 /* Only analyze the expressions for coarray properties, when in coarray-lib
10821 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10823 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10824 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10827 if (lss
!= gfc_ss_terminator
)
10829 /* The assignment needs scalarization. */
10832 /* Find a non-scalar SS from the lhs. */
10833 while (lss_section
!= gfc_ss_terminator
10834 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10835 lss_section
= lss_section
->next
;
10837 gcc_assert (lss_section
!= gfc_ss_terminator
);
10839 /* Initialize the scalarizer. */
10840 gfc_init_loopinfo (&loop
);
10842 /* Walk the rhs. */
10843 rss
= gfc_walk_expr (expr2
);
10844 if (rss
== gfc_ss_terminator
)
10845 /* The rhs is scalar. Add a ss for the expression. */
10846 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10847 /* When doing a class assign, then the handle to the rhs needs to be a
10848 pointer to allow for polymorphism. */
10849 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10850 rss
->info
->type
= GFC_SS_REFERENCE
;
10852 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10853 /* Associate the SS with the loop. */
10854 gfc_add_ss_to_loop (&loop
, lss
);
10855 gfc_add_ss_to_loop (&loop
, rss
);
10857 /* Calculate the bounds of the scalarization. */
10858 gfc_conv_ss_startstride (&loop
);
10859 /* Enable loop reversal. */
10860 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10861 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10862 /* Resolve any data dependencies in the statement. */
10864 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10865 /* Setup the scalarizing loops. */
10866 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10868 /* Setup the gfc_se structures. */
10869 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10870 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10873 gfc_mark_ss_chain_used (rss
, 1);
10874 if (loop
.temp_ss
== NULL
)
10877 gfc_mark_ss_chain_used (lss
, 1);
10881 lse
.ss
= loop
.temp_ss
;
10882 gfc_mark_ss_chain_used (lss
, 3);
10883 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10886 /* Allow the scalarizer to workshare array assignments. */
10887 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10888 == OMPWS_WORKSHARE_FLAG
10889 && loop
.temp_ss
== NULL
)
10891 maybe_workshare
= true;
10892 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10895 /* Start the scalarized loop body. */
10896 gfc_start_scalarized_body (&loop
, &body
);
10899 gfc_init_block (&body
);
10901 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10903 /* Translate the expression. */
10904 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10905 && lhs_caf_attr
.codimension
;
10906 gfc_conv_expr (&rse
, expr2
);
10908 /* Deal with the case of a scalar class function assigned to a derived type. */
10909 if (gfc_is_alloc_class_scalar_function (expr2
)
10910 && expr1
->ts
.type
== BT_DERIVED
)
10912 rse
.expr
= gfc_class_data_get (rse
.expr
);
10913 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10916 /* Stabilize a string length for temporaries. */
10917 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10918 && !(VAR_P (rse
.string_length
)
10919 || TREE_CODE (rse
.string_length
) == PARM_DECL
10920 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10921 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10922 else if (expr2
->ts
.type
== BT_CHARACTER
)
10924 if (expr1
->ts
.deferred
10925 && gfc_expr_attr (expr1
).allocatable
10926 && gfc_check_dependency (expr1
, expr2
, true))
10927 rse
.string_length
=
10928 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
10929 string_length
= rse
.string_length
;
10932 string_length
= NULL_TREE
;
10936 gfc_conv_tmp_array_ref (&lse
);
10937 if (expr2
->ts
.type
== BT_CHARACTER
)
10938 lse
.string_length
= string_length
;
10942 gfc_conv_expr (&lse
, expr1
);
10943 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10945 && gfc_expr_attr (expr1
).allocatable
10952 tmp
= INDIRECT_REF_P (lse
.expr
)
10953 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10955 /* We should only get array references here. */
10956 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10957 || TREE_CODE (tmp
) == ARRAY_REF
);
10959 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10960 or the array itself(ARRAY_REF). */
10961 tmp
= TREE_OPERAND (tmp
, 0);
10963 /* Provide the address of the array. */
10964 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10965 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10967 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10968 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10969 msg
= _("Assignment of scalar to unallocated array");
10970 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10971 &expr1
->where
, msg
);
10974 /* Deallocate the lhs parameterized components if required. */
10975 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10976 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10978 if (expr1
->ts
.type
== BT_DERIVED
10979 && expr1
->ts
.u
.derived
10980 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10982 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10984 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10986 else if (expr1
->ts
.type
== BT_CLASS
10987 && CLASS_DATA (expr1
)->ts
.u
.derived
10988 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10990 tmp
= gfc_class_data_get (lse
.expr
);
10991 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10993 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10998 /* Assignments of scalar derived types with allocatable components
10999 to arrays must be done with a deep copy and the rhs temporary
11000 must have its components deallocated afterwards. */
11001 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
11002 && expr2
->ts
.u
.derived
->attr
.alloc_comp
11003 && !gfc_expr_is_variable (expr2
)
11004 && expr1
->rank
&& !expr2
->rank
);
11005 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
11007 && expr1
->ts
.u
.derived
->attr
.alloc_comp
11008 && gfc_is_alloc_class_scalar_function (expr2
));
11009 if (scalar_to_array
&& dealloc
)
11011 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
11012 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
11015 /* When assigning a character function result to a deferred-length variable,
11016 the function call must happen before the (re)allocation of the lhs -
11017 otherwise the character length of the result is not known.
11018 NOTE 1: This relies on having the exact dependence of the length type
11019 parameter available to the caller; gfortran saves it in the .mod files.
11020 NOTE 2: Vector array references generate an index temporary that must
11021 not go outside the loop. Otherwise, variables should not generate
11023 NOTE 3: The concatenation operation generates a temporary pointer,
11024 whose allocation must go to the innermost loop.
11025 NOTE 4: Elemental functions may generate a temporary, too. */
11026 if (flag_realloc_lhs
11027 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
11028 && !(lss
!= gfc_ss_terminator
11029 && rss
!= gfc_ss_terminator
11030 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
11031 || (expr2
->expr_type
== EXPR_FUNCTION
11032 && expr2
->value
.function
.esym
!= NULL
11033 && expr2
->value
.function
.esym
->attr
.elemental
)
11034 || (expr2
->expr_type
== EXPR_FUNCTION
11035 && expr2
->value
.function
.isym
!= NULL
11036 && expr2
->value
.function
.isym
->elemental
)
11037 || (expr2
->expr_type
== EXPR_OP
11038 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
11039 gfc_add_block_to_block (&block
, &rse
.pre
);
11041 /* Nullify the allocatable components corresponding to those of the lhs
11042 derived type, so that the finalization of the function result does not
11043 affect the lhs of the assignment. Prepend is used to ensure that the
11044 nullification occurs before the call to the finalizer. In the case of
11045 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11046 as part of the deep copy. */
11047 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11048 && (gfc_is_class_array_function (expr2
)
11049 || gfc_is_alloc_class_scalar_function (expr2
)))
11052 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11053 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11054 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11055 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11060 if (is_poly_assign
)
11062 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11063 use_vptr_copy
|| (lhs_attr
.allocatable
11064 && !lhs_attr
.dimension
),
11065 !realloc_flag
&& flag_realloc_lhs
11066 && !lhs_attr
.pointer
);
11067 if (expr2
->expr_type
== EXPR_FUNCTION
11068 && expr2
->ts
.type
== BT_DERIVED
11069 && expr2
->ts
.u
.derived
->attr
.alloc_comp
)
11071 tree tmp2
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
,
11072 rse
.expr
, expr2
->rank
);
11073 if (lss
== gfc_ss_terminator
)
11074 gfc_add_expr_to_block (&rse
.post
, tmp2
);
11076 gfc_add_expr_to_block (&loop
.post
, tmp2
);
11079 else if (flag_coarray
== GFC_FCOARRAY_LIB
11080 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11081 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11082 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11084 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11085 allocatable component, because those need to be accessed via the
11086 caf-runtime. No need to check for coindexes here, because resolve
11087 has rewritten those already. */
11089 gfc_actual_arglist a1
, a2
;
11090 /* Clear the structures to prevent accessing garbage. */
11091 memset (&code
, '\0', sizeof (gfc_code
));
11092 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11093 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11098 code
.ext
.actual
= &a1
;
11099 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11100 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11102 else if (!is_poly_assign
&& expr2
->must_finalize
11103 && expr1
->ts
.type
== BT_CLASS
11104 && expr2
->ts
.type
== BT_CLASS
)
11106 /* This case comes about when the scalarizer provides array element
11107 references. Use the vptr copy function, since this does a deep
11108 copy of allocatable components, without which the finalizer call
11109 will deallocate the components. */
11110 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11111 if (tmp
!= NULL_TREE
)
11113 tree fcn
= gfc_vptr_copy_get (tmp
);
11114 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11115 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11116 tmp
= build_call_expr_loc (input_location
,
11118 gfc_build_addr_expr (NULL
, rse
.expr
),
11119 gfc_build_addr_expr (NULL
, lse
.expr
));
11123 /* If nothing else works, do it the old fashioned way! */
11124 if (tmp
== NULL_TREE
)
11125 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11126 gfc_expr_is_variable (expr2
)
11128 || expr2
->expr_type
== EXPR_ARRAY
,
11129 !(l_is_temp
|| init_flag
) && dealloc
,
11130 expr1
->symtree
->n
.sym
->attr
.codimension
);
11132 /* Add the pre blocks to the body. */
11133 gfc_add_block_to_block (&body
, &rse
.pre
);
11134 gfc_add_block_to_block (&body
, &lse
.pre
);
11135 gfc_add_expr_to_block (&body
, tmp
);
11136 /* Add the post blocks to the body. */
11137 gfc_add_block_to_block (&body
, &rse
.post
);
11138 gfc_add_block_to_block (&body
, &lse
.post
);
11140 if (lss
== gfc_ss_terminator
)
11142 /* F2003: Add the code for reallocation on assignment. */
11143 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11144 && !is_poly_assign
)
11145 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11148 /* Use the scalar assignment as is. */
11149 gfc_add_block_to_block (&block
, &body
);
11153 gcc_assert (lse
.ss
== gfc_ss_terminator
11154 && rse
.ss
== gfc_ss_terminator
);
11158 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11160 /* We need to copy the temporary to the actual lhs. */
11161 gfc_init_se (&lse
, NULL
);
11162 gfc_init_se (&rse
, NULL
);
11163 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11164 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11166 rse
.ss
= loop
.temp_ss
;
11169 gfc_conv_tmp_array_ref (&rse
);
11170 gfc_conv_expr (&lse
, expr1
);
11172 gcc_assert (lse
.ss
== gfc_ss_terminator
11173 && rse
.ss
== gfc_ss_terminator
);
11175 if (expr2
->ts
.type
== BT_CHARACTER
)
11176 rse
.string_length
= string_length
;
11178 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11180 gfc_add_expr_to_block (&body
, tmp
);
11183 /* F2003: Allocate or reallocate lhs of allocatable array. */
11186 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11187 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11188 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11189 if (tmp
!= NULL_TREE
)
11190 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11193 if (maybe_workshare
)
11194 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11196 /* Generate the copying loops. */
11197 gfc_trans_scalarizing_loops (&loop
, &body
);
11199 /* Wrap the whole thing up. */
11200 gfc_add_block_to_block (&block
, &loop
.pre
);
11201 gfc_add_block_to_block (&block
, &loop
.post
);
11203 gfc_cleanup_loop (&loop
);
11206 return gfc_finish_block (&block
);
11210 /* Check whether EXPR is a copyable array. */
11213 copyable_array_p (gfc_expr
* expr
)
11215 if (expr
->expr_type
!= EXPR_VARIABLE
)
11218 /* First check it's an array. */
11219 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11222 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11225 /* Next check that it's of a simple enough type. */
11226 switch (expr
->ts
.type
)
11238 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
11247 /* Translate an assignment. */
11250 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11251 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11255 /* Special case a single function returning an array. */
11256 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
11258 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
11263 /* Special case assigning an array to zero. */
11264 if (copyable_array_p (expr1
)
11265 && is_zero_initializer_p (expr2
))
11267 tmp
= gfc_trans_zero_assign (expr1
);
11272 /* Special case copying one array to another. */
11273 if (copyable_array_p (expr1
)
11274 && copyable_array_p (expr2
)
11275 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
11276 && !gfc_check_dependency (expr1
, expr2
, 0))
11278 tmp
= gfc_trans_array_copy (expr1
, expr2
);
11283 /* Special case initializing an array from a constant array constructor. */
11284 if (copyable_array_p (expr1
)
11285 && expr2
->expr_type
== EXPR_ARRAY
11286 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
11288 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
11293 if (UNLIMITED_POLY (expr1
) && expr1
->rank
)
11294 use_vptr_copy
= true;
11296 /* Fallback to the scalarizer to generate explicit loops. */
11297 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
11298 use_vptr_copy
, may_alias
);
11302 gfc_trans_init_assign (gfc_code
* code
)
11304 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
11308 gfc_trans_assign (gfc_code
* code
)
11310 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);