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
);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr
, int fieldno
)
266 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
267 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
269 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
270 TREE_TYPE (field
), vptr
, field
,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl
, int fieldno
)
283 vptr
= gfc_class_vptr_get (decl
);
284 return vptr_field_get (vptr
, fieldno
);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
303 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
304 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
305 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
306 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
307 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl
)
317 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
318 /* Always return size as an array index type. */
319 size
= fold_convert (gfc_array_index_type
, size
);
325 gfc_vptr_size_get (tree vptr
)
328 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
329 /* Always return size as an array index type. */
330 size
= fold_convert (gfc_array_index_type
, size
);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
358 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
360 /* Find the last class reference. */
363 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
365 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
380 if (ref
->next
== NULL
)
384 /* Remove and store all subsequent references after the
388 tail
= class_ref
->next
;
389 class_ref
->next
= NULL
;
391 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
397 base_expr
= gfc_copy_expr (e
);
399 /* Restore the original tail expression. */
402 gfc_free_ref_list (class_ref
->next
);
403 class_ref
->next
= tail
;
405 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
407 gfc_free_ref_list (e
->ref
);
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
417 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se
, NULL
);
427 gfc_conv_expr_descriptor (&se
, e
);
429 gfc_conv_expr (&se
, e
);
430 gfc_add_block_to_block (block
, &se
.pre
);
431 vptr
= gfc_get_vptr_from_expr (se
.expr
);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr
== NULL_TREE
)
437 if (UNLIMITED_POLY (e
))
438 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
441 /* Return the vptr to the address of the declared type. */
442 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
443 vtable
= vtab
->backend_decl
;
444 if (vtable
== NULL_TREE
)
445 vtable
= gfc_get_symbol_decl (vtab
);
446 vtable
= gfc_build_addr_expr (NULL
, vtable
);
447 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
448 gfc_add_modify (block
, vptr
, vtable
);
453 /* Reset the len for unlimited polymorphic objects. */
456 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
460 e
= gfc_find_and_cut_at_last_class_ref (expr
);
463 gfc_add_len_component (e
);
464 gfc_init_se (&se_len
, NULL
);
465 gfc_conv_expr (&se_len
, e
);
466 gfc_add_modify (block
, se_len
.expr
,
467 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
476 gfc_get_vptr_from_expr (tree expr
)
481 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
483 type
= TREE_TYPE (tmp
);
486 if (GFC_CLASS_TYPE_P (type
))
487 return gfc_class_vptr_get (tmp
);
488 if (type
!= TYPE_CANONICAL (type
))
489 type
= TYPE_CANONICAL (type
);
493 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
497 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
498 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
501 return gfc_class_vptr_get (tmp
);
508 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
511 tree tmp
, tmp2
, type
;
513 gfc_conv_descriptor_data_set (block
, lhs_desc
,
514 gfc_conv_descriptor_data_get (rhs_desc
));
515 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
516 gfc_conv_descriptor_offset_get (rhs_desc
));
518 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
519 gfc_conv_descriptor_dtype (rhs_desc
));
521 /* Assign the dimension as range-ref. */
522 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
523 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
525 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
526 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
527 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
528 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
529 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
530 gfc_add_modify (block
, tmp
, tmp2
);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
540 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
541 gfc_typespec class_ts
, tree vptr
, bool optional
,
542 bool optional_alloc_ptr
)
545 tree cond_optional
= NULL_TREE
;
552 /* The derived type needs to be converted to a temporary
554 tmp
= gfc_typenode_for_spec (&class_ts
);
555 var
= gfc_create_var (tmp
, "class");
558 ctree
= gfc_class_vptr_get (var
);
560 if (vptr
!= NULL_TREE
)
562 /* Use the dynamic vptr. */
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
571 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
573 gfc_add_modify (&parmse
->pre
, ctree
,
574 fold_convert (TREE_TYPE (ctree
), tmp
));
576 /* Now set the data field. */
577 ctree
= gfc_class_data_get (var
);
580 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
582 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
587 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
589 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse
, e
);
594 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
596 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
598 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
599 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
603 ss
= gfc_walk_expr (e
);
604 if (ss
== gfc_ss_terminator
)
607 gfc_conv_expr_reference (parmse
, e
);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts
.u
.derived
->components
->as
)
613 type
= get_scalar_to_descriptor_type (parmse
->expr
,
615 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
616 gfc_get_dtype (type
));
618 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
619 TREE_TYPE (parmse
->expr
),
620 cond_optional
, parmse
->expr
,
621 fold_convert (TREE_TYPE (parmse
->expr
),
623 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
627 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
629 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
631 fold_convert (TREE_TYPE (tmp
),
633 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
639 gfc_init_block (&block
);
643 parmse
->use_offset
= 1;
644 gfc_conv_expr_descriptor (parmse
, e
);
646 /* Detect any array references with vector subscripts. */
647 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
648 if (ref
->type
== REF_ARRAY
649 && ref
->u
.ar
.type
!= AR_ELEMENT
650 && ref
->u
.ar
.type
!= AR_FULL
)
652 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
653 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
655 if (dim
< ref
->u
.ar
.dimen
)
659 /* Array references with vector subscripts and non-variable expressions
660 need be converted to a one-based descriptor. */
661 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
663 for (dim
= 0; dim
< e
->rank
; ++dim
)
664 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
668 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
670 gcc_assert (class_ts
.u
.derived
->components
->as
->type
672 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
676 if (gfc_expr_attr (e
).codimension
)
677 parmse
->expr
= fold_build1_loc (input_location
,
681 gfc_add_modify (&block
, ctree
, parmse
->expr
);
686 tmp
= gfc_finish_block (&block
);
688 gfc_init_block (&block
);
689 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
691 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
692 gfc_finish_block (&block
));
693 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
696 gfc_add_block_to_block (&parmse
->pre
, &block
);
700 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
701 && class_ts
.u
.derived
->components
->ts
.u
.derived
702 ->attr
.unlimited_polymorphic
)
704 /* Take care about initializing the _len component correctly. */
705 ctree
= gfc_class_len_get (var
);
706 if (UNLIMITED_POLY (e
))
711 len
= gfc_copy_expr (e
);
712 gfc_add_len_component (len
);
713 gfc_init_se (&se
, NULL
);
714 gfc_conv_expr (&se
, len
);
716 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
717 cond_optional
, se
.expr
,
718 fold_convert (TREE_TYPE (se
.expr
),
724 tmp
= integer_zero_node
;
725 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
728 /* Pass the address of the class object. */
729 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
731 if (optional
&& optional_alloc_ptr
)
732 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
733 TREE_TYPE (parmse
->expr
),
734 cond_optional
, parmse
->expr
,
735 fold_convert (TREE_TYPE (parmse
->expr
),
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
745 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
746 gfc_typespec class_ts
, bool optional
)
748 tree var
, ctree
, tmp
;
753 gfc_init_block (&block
);
756 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
758 if (ref
->type
== REF_COMPONENT
759 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
763 if (class_ref
== NULL
764 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
765 tmp
= e
->symtree
->n
.sym
->backend_decl
;
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
771 ref
= class_ref
->next
;
772 class_ref
->next
= NULL
;
773 gfc_init_se (&tmpse
, NULL
);
774 gfc_conv_expr (&tmpse
, e
);
775 class_ref
->next
= ref
;
779 var
= gfc_typenode_for_spec (&class_ts
);
780 var
= gfc_create_var (var
, "class");
782 ctree
= gfc_class_vptr_get (var
);
783 gfc_add_modify (&block
, ctree
,
784 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
786 ctree
= gfc_class_data_get (var
);
787 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
788 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
790 /* Pass the address of the class object. */
791 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
795 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
798 tmp
= gfc_finish_block (&block
);
800 gfc_init_block (&block
);
801 tmp2
= gfc_class_data_get (var
);
802 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
804 tmp2
= gfc_finish_block (&block
);
806 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
808 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
811 gfc_add_block_to_block (&parmse
->pre
, &block
);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
818 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
819 gfc_typespec class_ts
)
827 /* The intrinsic type needs to be converted to a temporary
829 tmp
= gfc_typenode_for_spec (&class_ts
);
830 var
= gfc_create_var (tmp
, "class");
833 ctree
= gfc_class_vptr_get (var
);
835 vtab
= gfc_find_vtab (&e
->ts
);
837 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
838 gfc_add_modify (&parmse
->pre
, ctree
,
839 fold_convert (TREE_TYPE (ctree
), tmp
));
841 /* Now set the data field. */
842 ctree
= gfc_class_data_get (var
);
843 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse
, e
);
848 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
849 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
853 ss
= gfc_walk_expr (e
);
854 if (ss
== gfc_ss_terminator
)
857 gfc_conv_expr_reference (parmse
, e
);
858 if (class_ts
.u
.derived
->components
->as
859 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
861 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
863 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
864 TREE_TYPE (ctree
), tmp
);
867 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
868 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
873 parmse
->use_offset
= 1;
874 gfc_conv_expr_descriptor (parmse
, e
);
875 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
877 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
878 TREE_TYPE (ctree
), parmse
->expr
);
879 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
882 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
886 gcc_assert (class_ts
.type
== BT_CLASS
);
887 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
888 && class_ts
.u
.derived
->components
->ts
.u
.derived
889 ->attr
.unlimited_polymorphic
)
891 ctree
= gfc_class_len_get (var
);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e
->ts
.type
== BT_CHARACTER
)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse
->string_length
)
899 tmp
= parmse
->string_length
;
900 /* When the string_length is not yet set, then try the backend_decl of
902 else if (e
->ts
.u
.cl
->backend_decl
)
903 tmp
= e
->ts
.u
.cl
->backend_decl
;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e
, 0);
911 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
916 gfc_charlen_int_kind
,
918 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
919 e
->value
.character
.length
);
920 gfc_conv_const_charlen (e
->ts
.u
.cl
);
921 e
->ts
.u
.cl
->resolved
= 1;
922 tmp
= e
->ts
.u
.cl
->backend_decl
;
926 gfc_error ("Can't compute the length of the char array at %L.",
932 tmp
= integer_zero_node
;
934 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
936 else if (class_ts
.type
== BT_CLASS
937 && class_ts
.u
.derived
->components
938 && class_ts
.u
.derived
->components
->ts
.u
939 .derived
->attr
.unlimited_polymorphic
)
941 ctree
= gfc_class_len_get (var
);
942 gfc_add_modify (&parmse
->pre
, ctree
,
943 fold_convert (TREE_TYPE (ctree
),
946 /* Pass the address of the class object. */
947 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
963 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
964 bool elemental
, bool copyback
, bool optional
,
965 bool optional_alloc_ptr
)
971 tree cond
= NULL_TREE
;
972 tree slen
= NULL_TREE
;
976 bool full_array
= false;
978 gfc_init_block (&block
);
981 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
983 if (ref
->type
== REF_COMPONENT
984 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
987 if (ref
->next
== NULL
)
991 if ((ref
== NULL
|| class_ref
== ref
)
992 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
993 && (!class_ts
.u
.derived
->components
->as
994 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
997 /* Test for FULL_ARRAY. */
998 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
999 && gfc_expr_attr (e
).dimension
)
1002 gfc_is_class_array_ref (e
, &full_array
);
1004 /* The derived type needs to be converted to a temporary
1006 tmp
= gfc_typenode_for_spec (&class_ts
);
1007 var
= gfc_create_var (tmp
, "class");
1010 ctree
= gfc_class_data_get (var
);
1011 if (class_ts
.u
.derived
->components
->as
1012 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1016 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1018 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1019 gfc_get_dtype (type
));
1021 tmp
= gfc_class_data_get (parmse
->expr
);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1023 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1025 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1028 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1032 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1033 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1034 TREE_TYPE (ctree
), parmse
->expr
);
1035 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1041 if (!elemental
&& full_array
&& copyback
)
1043 if (class_ts
.u
.derived
->components
->as
1044 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1047 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1048 gfc_conv_descriptor_data_get (ctree
));
1050 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1053 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1057 ctree
= gfc_class_vptr_get (var
);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1063 if (gfc_is_class_array_function (e
)
1064 && parmse
->class_vptr
!= NULL_TREE
)
1065 tmp
= parmse
->class_vptr
;
1066 else if (class_ref
== NULL
1067 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1069 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1071 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1072 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1074 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1075 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1077 slen
= build_zero_cst (size_type_node
);
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1084 ref
= class_ref
->next
;
1085 class_ref
->next
= NULL
;
1086 gfc_init_se (&tmpse
, NULL
);
1087 gfc_conv_expr (&tmpse
, e
);
1088 class_ref
->next
= ref
;
1090 slen
= tmpse
.string_length
;
1093 gcc_assert (tmp
!= NULL_TREE
);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1097 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1099 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1100 vptr
= gfc_class_vptr_get (tmp
);
1104 gfc_add_modify (&block
, ctree
,
1105 fold_convert (TREE_TYPE (ctree
), vptr
));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental
&& full_array
&& copyback
)
1110 gfc_add_modify (&parmse
->post
, vptr
,
1111 fold_convert (TREE_TYPE (vptr
), ctree
));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts
.type
== BT_CLASS
1115 && class_ts
.u
.derived
->components
1116 && class_ts
.u
.derived
->components
->ts
.u
1117 .derived
->attr
.unlimited_polymorphic
)
1119 ctree
= gfc_class_len_get (var
);
1120 if (UNLIMITED_POLY (e
))
1121 tmp
= gfc_class_len_get (tmp
);
1122 else if (e
->ts
.type
== BT_CHARACTER
)
1124 gcc_assert (slen
!= NULL_TREE
);
1128 tmp
= build_zero_cst (size_type_node
);
1129 gfc_add_modify (&parmse
->pre
, ctree
,
1130 fold_convert (TREE_TYPE (ctree
), tmp
));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental
&& full_array
&& copyback
1135 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1136 gfc_add_modify (&parmse
->post
, tmp
,
1137 fold_convert (TREE_TYPE (tmp
), ctree
));
1144 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1145 /* parmse->pre may contain some preparatory instructions for the
1146 temporary array descriptor. Those may only be executed when the
1147 optional argument is set, therefore add parmse->pre's instructions
1148 to block, which is later guarded by an if (optional_arg_given). */
1149 gfc_add_block_to_block (&parmse
->pre
, &block
);
1150 block
.head
= parmse
->pre
.head
;
1151 parmse
->pre
.head
= NULL_TREE
;
1152 tmp
= gfc_finish_block (&block
);
1154 if (optional_alloc_ptr
)
1155 tmp2
= build_empty_stmt (input_location
);
1158 gfc_init_block (&block
);
1160 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1161 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1162 null_pointer_node
));
1163 tmp2
= gfc_finish_block (&block
);
1166 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1168 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1171 gfc_add_block_to_block (&parmse
->pre
, &block
);
1173 /* Pass the address of the class object. */
1174 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1176 if (optional
&& optional_alloc_ptr
)
1177 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1178 TREE_TYPE (parmse
->expr
),
1180 fold_convert (TREE_TYPE (parmse
->expr
),
1181 null_pointer_node
));
1185 /* Given a class array declaration and an index, returns the address
1186 of the referenced element. */
1189 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1192 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1194 data
= data_comp
!= NULL_TREE
? data_comp
:
1195 gfc_class_data_get (class_decl
);
1196 size
= gfc_class_vtab_size_get (class_decl
);
1200 tmp
= fold_convert (gfc_array_index_type
,
1201 gfc_class_len_get (class_decl
));
1202 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1203 gfc_array_index_type
, size
, tmp
);
1204 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1205 logical_type_node
, tmp
,
1206 build_zero_cst (TREE_TYPE (tmp
)));
1207 size
= fold_build3_loc (input_location
, COND_EXPR
,
1208 gfc_array_index_type
, tmp
, ctmp
, size
);
1211 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1212 gfc_array_index_type
,
1215 data
= gfc_conv_descriptor_data_get (data
);
1216 ptr
= fold_convert (pvoid_type_node
, data
);
1217 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1218 return fold_convert (TREE_TYPE (data
), ptr
);
1222 /* Copies one class expression to another, assuming that if either
1223 'to' or 'from' are arrays they are packed. Should 'from' be
1224 NULL_TREE, the initialization expression for 'to' is used, assuming
1225 that the _vptr is set. */
1228 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1238 vec
<tree
, va_gc
> *args
;
1243 bool is_from_desc
= false, is_to_class
= false;
1246 /* To prevent warnings on uninitialized variables. */
1247 from_len
= to_len
= NULL_TREE
;
1249 if (from
!= NULL_TREE
)
1250 fcn
= gfc_class_vtab_copy_get (from
);
1252 fcn
= gfc_class_vtab_copy_get (to
);
1254 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1256 if (from
!= NULL_TREE
)
1258 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1262 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1266 /* Check that from is a class. When the class is part of a coarray,
1267 then from is a common pointer and is to be used as is. */
1268 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1269 ? build_fold_indirect_ref (from
) : from
;
1271 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1272 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1273 ? gfc_class_data_get (from
) : from
;
1274 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1278 from_data
= gfc_class_vtab_def_init_get (to
);
1282 if (from
!= NULL_TREE
&& unlimited
)
1283 from_len
= gfc_class_len_or_zero_get (from
);
1285 from_len
= build_zero_cst (size_type_node
);
1288 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1291 to_data
= gfc_class_data_get (to
);
1293 to_len
= gfc_class_len_get (to
);
1296 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1299 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1301 stmtblock_t loopbody
;
1305 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1307 gfc_init_block (&body
);
1308 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1309 gfc_array_index_type
, nelems
,
1310 gfc_index_one_node
);
1311 nelems
= gfc_evaluate_now (tmp
, &body
);
1312 index
= gfc_create_var (gfc_array_index_type
, "S");
1316 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1318 vec_safe_push (args
, from_ref
);
1321 vec_safe_push (args
, from_data
);
1324 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1327 tmp
= gfc_conv_array_data (to
);
1328 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1329 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1330 gfc_build_array_ref (tmp
, index
, to
));
1332 vec_safe_push (args
, to_ref
);
1334 /* Add bounds check. */
1335 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1338 const char *name
= "<<unknown>>";
1342 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1344 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1345 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1346 logical_type_node
, from_len
, orig_nelems
);
1347 msg
= xasprintf ("Array bound mismatch for dimension %d "
1348 "of array '%s' (%%ld/%%ld)",
1351 gfc_trans_runtime_check (true, false, tmp
, &body
,
1352 &gfc_current_locus
, msg
,
1353 fold_convert (long_integer_type_node
, orig_nelems
),
1354 fold_convert (long_integer_type_node
, from_len
));
1359 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1361 /* Build the body of the loop. */
1362 gfc_init_block (&loopbody
);
1363 gfc_add_expr_to_block (&loopbody
, tmp
);
1365 /* Build the loop and return. */
1366 gfc_init_loopinfo (&loop
);
1368 loop
.from
[0] = gfc_index_zero_node
;
1369 loop
.loopvar
[0] = index
;
1370 loop
.to
[0] = nelems
;
1371 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1372 gfc_init_block (&ifbody
);
1373 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1374 stdcopy
= gfc_finish_block (&ifbody
);
1375 /* In initialization mode from_len is a constant zero. */
1376 if (unlimited
&& !integer_zerop (from_len
))
1378 vec_safe_push (args
, from_len
);
1379 vec_safe_push (args
, to_len
);
1380 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody
);
1383 gfc_add_expr_to_block (&loopbody
, tmp
);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop
);
1388 loop
.from
[0] = gfc_index_zero_node
;
1389 loop
.loopvar
[0] = index
;
1390 loop
.to
[0] = nelems
;
1391 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1392 gfc_init_block (&ifbody
);
1393 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1394 extcopy
= gfc_finish_block (&ifbody
);
1396 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1397 logical_type_node
, from_len
,
1398 build_zero_cst (TREE_TYPE (from_len
)));
1399 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1400 void_type_node
, tmp
, extcopy
, stdcopy
);
1401 gfc_add_expr_to_block (&body
, tmp
);
1402 tmp
= gfc_finish_block (&body
);
1406 gfc_add_expr_to_block (&body
, stdcopy
);
1407 tmp
= gfc_finish_block (&body
);
1409 gfc_cleanup_loop (&loop
);
1413 gcc_assert (!is_from_desc
);
1414 vec_safe_push (args
, from_data
);
1415 vec_safe_push (args
, to_data
);
1416 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1418 /* In initialization mode from_len is a constant zero. */
1419 if (unlimited
&& !integer_zerop (from_len
))
1421 vec_safe_push (args
, from_len
);
1422 vec_safe_push (args
, to_len
);
1423 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1424 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1425 logical_type_node
, from_len
,
1426 build_zero_cst (TREE_TYPE (from_len
)));
1427 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1428 void_type_node
, tmp
, extcopy
, stdcopy
);
1434 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1435 if (from
== NULL_TREE
)
1438 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1440 from_data
, null_pointer_node
);
1441 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1442 void_type_node
, cond
,
1443 tmp
, build_empty_stmt (input_location
));
1451 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1453 gfc_actual_arglist
*actual
;
1458 actual
= gfc_get_actual_arglist ();
1459 actual
->expr
= gfc_copy_expr (rhs
);
1460 actual
->next
= gfc_get_actual_arglist ();
1461 actual
->next
->expr
= gfc_copy_expr (lhs
);
1462 ppc
= gfc_copy_expr (obj
);
1463 gfc_add_vptr_component (ppc
);
1464 gfc_add_component_ref (ppc
, "_copy");
1465 ppc_code
= gfc_get_code (EXEC_CALL
);
1466 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1467 /* Although '_copy' is set to be elemental in class.c, it is
1468 not staying that way. Find out why, sometime.... */
1469 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1470 ppc_code
->ext
.actual
= actual
;
1471 ppc_code
->expr1
= ppc
;
1472 /* Since '_copy' is elemental, the scalarizer will take care
1473 of arrays in gfc_trans_call. */
1474 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1475 gfc_free_statements (ppc_code
);
1477 if (UNLIMITED_POLY(obj
))
1479 /* Check if rhs is non-NULL. */
1481 gfc_init_se (&src
, NULL
);
1482 gfc_conv_expr (&src
, rhs
);
1483 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1484 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1485 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1486 null_pointer_node
));
1487 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1488 build_empty_stmt (input_location
));
1494 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1495 A MEMCPY is needed to copy the full data from the default initializer
1496 of the dynamic type. */
1499 gfc_trans_class_init_assign (gfc_code
*code
)
1503 gfc_se dst
,src
,memsz
;
1504 gfc_expr
*lhs
, *rhs
, *sz
;
1506 gfc_start_block (&block
);
1508 lhs
= gfc_copy_expr (code
->expr1
);
1510 rhs
= gfc_copy_expr (code
->expr1
);
1511 gfc_add_vptr_component (rhs
);
1513 /* Make sure that the component backend_decls have been built, which
1514 will not have happened if the derived types concerned have not
1516 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1517 gfc_add_def_init_component (rhs
);
1518 /* The _def_init is always scalar. */
1521 if (code
->expr1
->ts
.type
== BT_CLASS
1522 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1524 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1525 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1526 /* Adding the array ref to the class expression results in correct
1527 indexing to the dynamic type. */
1528 gfc_add_full_array_ref (lhs
, tmparr
);
1529 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1533 /* Scalar initialization needs the _data component. */
1534 gfc_add_data_component (lhs
);
1535 sz
= gfc_copy_expr (code
->expr1
);
1536 gfc_add_vptr_component (sz
);
1537 gfc_add_size_component (sz
);
1539 gfc_init_se (&dst
, NULL
);
1540 gfc_init_se (&src
, NULL
);
1541 gfc_init_se (&memsz
, NULL
);
1542 gfc_conv_expr (&dst
, lhs
);
1543 gfc_conv_expr (&src
, rhs
);
1544 gfc_conv_expr (&memsz
, sz
);
1545 gfc_add_block_to_block (&block
, &src
.pre
);
1546 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1548 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1550 if (UNLIMITED_POLY(code
->expr1
))
1552 /* Check if _def_init is non-NULL. */
1553 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1554 logical_type_node
, src
.expr
,
1555 fold_convert (TREE_TYPE (src
.expr
),
1556 null_pointer_node
));
1557 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1558 tmp
, build_empty_stmt (input_location
));
1562 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1563 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1565 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1566 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1568 build_empty_stmt (input_location
));
1571 gfc_add_expr_to_block (&block
, tmp
);
1573 return gfc_finish_block (&block
);
1577 /* End of prototype trans-class.c */
1581 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1583 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1584 gfc_warning (OPT_Wrealloc_lhs
,
1585 "Code for reallocating the allocatable array at %L will "
1587 else if (warn_realloc_lhs_all
)
1588 gfc_warning (OPT_Wrealloc_lhs_all
,
1589 "Code for reallocating the allocatable variable at %L "
1590 "will be added", where
);
1594 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1597 /* Copy the scalarization loop variables. */
1600 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1603 dest
->loop
= src
->loop
;
1607 /* Initialize a simple expression holder.
1609 Care must be taken when multiple se are created with the same parent.
1610 The child se must be kept in sync. The easiest way is to delay creation
1611 of a child se until after after the previous se has been translated. */
1614 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1616 memset (se
, 0, sizeof (gfc_se
));
1617 gfc_init_block (&se
->pre
);
1618 gfc_init_block (&se
->post
);
1620 se
->parent
= parent
;
1623 gfc_copy_se_loopvars (se
, parent
);
1627 /* Advances to the next SS in the chain. Use this rather than setting
1628 se->ss = se->ss->next because all the parents needs to be kept in sync.
1632 gfc_advance_se_ss_chain (gfc_se
* se
)
1637 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1640 /* Walk down the parent chain. */
1643 /* Simple consistency check. */
1644 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1645 || p
->parent
->ss
->nested_ss
== p
->ss
);
1647 /* If we were in a nested loop, the next scalarized expression can be
1648 on the parent ss' next pointer. Thus we should not take the next
1649 pointer blindly, but rather go up one nest level as long as next
1650 is the end of chain. */
1652 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1662 /* Ensures the result of the expression as either a temporary variable
1663 or a constant so that it can be used repeatedly. */
1666 gfc_make_safe_expr (gfc_se
* se
)
1670 if (CONSTANT_CLASS_P (se
->expr
))
1673 /* We need a temporary for this result. */
1674 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1675 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1680 /* Return an expression which determines if a dummy parameter is present.
1681 Also used for arguments to procedures with multiple entry points. */
1684 gfc_conv_expr_present (gfc_symbol
* sym
)
1688 gcc_assert (sym
->attr
.dummy
);
1689 decl
= gfc_get_symbol_decl (sym
);
1691 /* Intrinsic scalars with VALUE attribute which are passed by value
1692 use a hidden argument to denote the present status. */
1693 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1694 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1695 && !sym
->attr
.dimension
)
1697 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1700 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1702 strcpy (&name
[1], sym
->name
);
1703 tree_name
= get_identifier (name
);
1705 /* Walk function argument list to find hidden arg. */
1706 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1707 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1708 if (DECL_NAME (cond
) == tree_name
)
1715 if (TREE_CODE (decl
) != PARM_DECL
)
1717 /* Array parameters use a temporary descriptor, we want the real
1719 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1720 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1721 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1724 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1725 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1727 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1728 as actual argument to denote absent dummies. For array descriptors,
1729 we thus also need to check the array descriptor. For BT_CLASS, it
1730 can also occur for scalars and F2003 due to type->class wrapping and
1731 class->class wrapping. Note further that BT_CLASS always uses an
1732 array descriptor for arrays, also for explicit-shape/assumed-size. */
1734 if (!sym
->attr
.allocatable
1735 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1736 || (sym
->ts
.type
== BT_CLASS
1737 && !CLASS_DATA (sym
)->attr
.allocatable
1738 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1739 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1740 || sym
->ts
.type
== BT_CLASS
))
1744 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1745 || sym
->as
->type
== AS_ASSUMED_RANK
1746 || sym
->attr
.codimension
))
1747 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1749 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1750 if (sym
->ts
.type
== BT_CLASS
)
1751 tmp
= gfc_class_data_get (tmp
);
1752 tmp
= gfc_conv_array_data (tmp
);
1754 else if (sym
->ts
.type
== BT_CLASS
)
1755 tmp
= gfc_class_data_get (decl
);
1759 if (tmp
!= NULL_TREE
)
1761 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1762 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1763 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1764 logical_type_node
, cond
, tmp
);
1772 /* Converts a missing, dummy argument into a null or zero. */
1775 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1780 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1784 /* Create a temporary and convert it to the correct type. */
1785 tmp
= gfc_get_int_type (kind
);
1786 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1789 /* Test for a NULL value. */
1790 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1791 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1792 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1793 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1797 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1799 build_zero_cst (TREE_TYPE (se
->expr
)));
1800 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1804 if (ts
.type
== BT_CHARACTER
)
1806 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1807 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1808 present
, se
->string_length
, tmp
);
1809 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1810 se
->string_length
= tmp
;
1816 /* Get the character length of an expression, looking through gfc_refs
1820 gfc_get_expr_charlen (gfc_expr
*e
)
1825 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1826 && e
->ts
.type
== BT_CHARACTER
);
1828 length
= NULL
; /* To silence compiler warning. */
1830 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1833 gfc_init_se (&tmpse
, NULL
);
1834 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1835 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1839 /* First candidate: if the variable is of type CHARACTER, the
1840 expression's length could be the length of the character
1842 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1843 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1845 /* Look through the reference chain for component references. */
1846 for (r
= e
->ref
; r
; r
= r
->next
)
1851 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1852 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1860 /* We should never got substring references here. These will be
1861 broken down by the scalarizer. */
1867 gcc_assert (length
!= NULL
);
1872 /* Return for an expression the backend decl of the coarray. */
1875 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1881 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1883 /* Not-implemented diagnostic. */
1884 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1885 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1886 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1887 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1888 "%L is not supported", &expr
->where
);
1890 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1891 if (ref
->type
== REF_COMPONENT
)
1893 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1894 && UNLIMITED_POLY (ref
->u
.c
.component
)
1895 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1896 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1897 "component at %L is not supported", &expr
->where
);
1900 /* Make sure the backend_decl is present before accessing it. */
1901 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1902 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1903 : expr
->symtree
->n
.sym
->backend_decl
;
1905 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1907 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1909 caf_decl
= gfc_class_data_get (caf_decl
);
1910 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1913 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1915 if (ref
->type
== REF_COMPONENT
1916 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1918 caf_decl
= gfc_class_data_get (caf_decl
);
1919 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1923 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1927 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1930 /* The following code assumes that the coarray is a component reachable via
1931 only scalar components/variables; the Fortran standard guarantees this. */
1933 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1934 if (ref
->type
== REF_COMPONENT
)
1936 gfc_component
*comp
= ref
->u
.c
.component
;
1938 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1939 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1940 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1941 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1942 comp
->backend_decl
, NULL_TREE
);
1943 if (comp
->ts
.type
== BT_CLASS
)
1945 caf_decl
= gfc_class_data_get (caf_decl
);
1946 if (CLASS_DATA (comp
)->attr
.codimension
)
1952 if (comp
->attr
.codimension
)
1958 gcc_assert (found
&& caf_decl
);
1963 /* Obtain the Coarray token - and optionally also the offset. */
1966 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1967 tree se_expr
, gfc_expr
*expr
)
1971 /* Coarray token. */
1972 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1974 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1975 == GFC_ARRAY_ALLOCATABLE
1976 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1977 *token
= gfc_conv_descriptor_token (caf_decl
);
1979 else if (DECL_LANG_SPECIFIC (caf_decl
)
1980 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1981 *token
= GFC_DECL_TOKEN (caf_decl
);
1984 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1985 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1986 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1992 /* Offset between the coarray base address and the address wanted. */
1993 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1994 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1995 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1996 *offset
= build_int_cst (gfc_array_index_type
, 0);
1997 else if (DECL_LANG_SPECIFIC (caf_decl
)
1998 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1999 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2000 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2001 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2003 *offset
= build_int_cst (gfc_array_index_type
, 0);
2005 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2006 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2008 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2009 tmp
= gfc_conv_descriptor_data_get (tmp
);
2011 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2012 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2019 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2020 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2022 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2023 && expr
->symtree
->n
.sym
->attr
.codimension
2024 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2026 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2027 gfc_ref
*ref
= base_expr
->ref
;
2030 // Iterate through the refs until the last one.
2034 if (ref
->type
== REF_ARRAY
2035 && ref
->u
.ar
.type
!= AR_FULL
)
2037 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2039 for (i
= 0; i
< ranksum
; ++i
)
2041 ref
->u
.ar
.start
[i
] = NULL
;
2042 ref
->u
.ar
.end
[i
] = NULL
;
2044 ref
->u
.ar
.type
= AR_FULL
;
2046 gfc_init_se (&base_se
, NULL
);
2047 if (gfc_caf_attr (base_expr
).dimension
)
2049 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2050 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2054 gfc_conv_expr (&base_se
, base_expr
);
2058 gfc_free_expr (base_expr
);
2059 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2060 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2062 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2063 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2066 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2070 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2071 fold_convert (gfc_array_index_type
, *offset
),
2072 fold_convert (gfc_array_index_type
, tmp
));
2076 /* Convert the coindex of a coarray into an image index; the result is
2077 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2078 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2081 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2084 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2088 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2089 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2091 gcc_assert (ref
!= NULL
);
2093 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2095 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2099 img_idx
= build_zero_cst (gfc_array_index_type
);
2100 extent
= build_one_cst (gfc_array_index_type
);
2101 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2102 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2104 gfc_init_se (&se
, NULL
);
2105 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2106 gfc_add_block_to_block (block
, &se
.pre
);
2107 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2108 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2109 TREE_TYPE (lbound
), se
.expr
, lbound
);
2110 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2112 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2113 TREE_TYPE (tmp
), img_idx
, tmp
);
2114 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2116 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2117 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2118 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2119 TREE_TYPE (tmp
), extent
, tmp
);
2123 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2125 gfc_init_se (&se
, NULL
);
2126 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2127 gfc_add_block_to_block (block
, &se
.pre
);
2128 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2129 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2130 TREE_TYPE (lbound
), se
.expr
, lbound
);
2131 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2133 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2135 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2137 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2138 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2139 TREE_TYPE (ubound
), ubound
, lbound
);
2140 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2141 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2142 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2143 TREE_TYPE (tmp
), extent
, tmp
);
2146 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2147 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2148 return fold_convert (integer_type_node
, img_idx
);
2152 /* For each character array constructor subexpression without a ts.u.cl->length,
2153 replace it by its first element (if there aren't any elements, the length
2154 should already be set to zero). */
2157 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2159 gfc_actual_arglist
* arg
;
2165 switch (e
->expr_type
)
2169 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2170 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2174 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2178 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2179 flatten_array_ctors_without_strlen (arg
->expr
);
2184 /* We've found what we're looking for. */
2185 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2190 gcc_assert (e
->value
.constructor
);
2192 c
= gfc_constructor_first (e
->value
.constructor
);
2196 flatten_array_ctors_without_strlen (new_expr
);
2197 gfc_replace_expr (e
, new_expr
);
2201 /* Otherwise, fall through to handle constructor elements. */
2203 case EXPR_STRUCTURE
:
2204 for (c
= gfc_constructor_first (e
->value
.constructor
);
2205 c
; c
= gfc_constructor_next (c
))
2206 flatten_array_ctors_without_strlen (c
->expr
);
2216 /* Generate code to initialize a string length variable. Returns the
2217 value. For array constructors, cl->length might be NULL and in this case,
2218 the first element of the constructor is needed. expr is the original
2219 expression so we can access it but can be NULL if this is not needed. */
2222 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2226 gfc_init_se (&se
, NULL
);
2228 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2231 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2232 "flatten" array constructors by taking their first element; all elements
2233 should be the same length or a cl->length should be present. */
2236 gfc_expr
* expr_flat
;
2239 expr_flat
= gfc_copy_expr (expr
);
2240 flatten_array_ctors_without_strlen (expr_flat
);
2241 gfc_resolve_expr (expr_flat
);
2243 gfc_conv_expr (&se
, expr_flat
);
2244 gfc_add_block_to_block (pblock
, &se
.pre
);
2245 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2247 gfc_free_expr (expr_flat
);
2251 /* Convert cl->length. */
2253 gcc_assert (cl
->length
);
2255 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2256 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2257 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2258 gfc_add_block_to_block (pblock
, &se
.pre
);
2260 if (cl
->backend_decl
)
2261 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2263 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2268 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2269 const char *name
, locus
*where
)
2279 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2280 type
= build_pointer_type (type
);
2282 gfc_init_se (&start
, se
);
2283 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2284 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2286 if (integer_onep (start
.expr
))
2287 gfc_conv_string_parameter (se
);
2292 /* Avoid multiple evaluation of substring start. */
2293 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2294 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2296 /* Change the start of the string. */
2297 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2300 tmp
= build_fold_indirect_ref_loc (input_location
,
2302 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2303 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2306 /* Length = end + 1 - start. */
2307 gfc_init_se (&end
, se
);
2308 if (ref
->u
.ss
.end
== NULL
)
2309 end
.expr
= se
->string_length
;
2312 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2313 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2317 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2318 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2320 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2322 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2323 logical_type_node
, start
.expr
,
2326 /* Check lower bound. */
2327 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2329 build_one_cst (TREE_TYPE (start
.expr
)));
2330 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2331 logical_type_node
, nonempty
, fault
);
2333 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2334 "is less than one", name
);
2336 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2337 "is less than one");
2338 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2339 fold_convert (long_integer_type_node
,
2343 /* Check upper bound. */
2344 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2345 end
.expr
, se
->string_length
);
2346 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2347 logical_type_node
, nonempty
, fault
);
2349 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2350 "exceeds string length (%%ld)", name
);
2352 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2353 "exceeds string length (%%ld)");
2354 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2355 fold_convert (long_integer_type_node
, end
.expr
),
2356 fold_convert (long_integer_type_node
,
2357 se
->string_length
));
2361 /* Try to calculate the length from the start and end expressions. */
2363 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2365 HOST_WIDE_INT i_len
;
2367 i_len
= gfc_mpz_get_hwi (length
) + 1;
2371 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2372 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2376 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2377 fold_convert (gfc_charlen_type_node
, end
.expr
),
2378 fold_convert (gfc_charlen_type_node
, start
.expr
));
2379 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2380 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2381 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2382 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2385 se
->string_length
= tmp
;
2389 /* Convert a derived type component reference. */
2392 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2400 c
= ref
->u
.c
.component
;
2402 if (c
->backend_decl
== NULL_TREE
2403 && ref
->u
.c
.sym
!= NULL
)
2404 gfc_get_derived_type (ref
->u
.c
.sym
);
2406 field
= c
->backend_decl
;
2407 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2409 context
= DECL_FIELD_CONTEXT (field
);
2411 /* Components can correspond to fields of different containing
2412 types, as components are created without context, whereas
2413 a concrete use of a component has the type of decl as context.
2414 So, if the type doesn't match, we search the corresponding
2415 FIELD_DECL in the parent type. To not waste too much time
2416 we cache this result in norestrict_decl.
2417 On the other hand, if the context is a UNION or a MAP (a
2418 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2420 if (context
!= TREE_TYPE (decl
)
2421 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2422 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2424 tree f2
= c
->norestrict_decl
;
2425 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2426 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2427 if (TREE_CODE (f2
) == FIELD_DECL
2428 && DECL_NAME (f2
) == DECL_NAME (field
))
2431 c
->norestrict_decl
= f2
;
2435 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2436 && strcmp ("_data", c
->name
) == 0)
2438 /* Found a ref to the _data component. Store the associated ref to
2439 the vptr in se->class_vptr. */
2440 se
->class_vptr
= gfc_class_vptr_get (decl
);
2443 se
->class_vptr
= NULL_TREE
;
2445 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2446 decl
, field
, NULL_TREE
);
2450 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2451 strlen () conditional below. */
2452 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2453 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2454 && !c
->attr
.pdt_string
)
2456 tmp
= c
->ts
.u
.cl
->backend_decl
;
2457 /* Components must always be constant length. */
2458 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2459 se
->string_length
= tmp
;
2462 if (gfc_deferred_strlen (c
, &field
))
2464 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2466 decl
, field
, NULL_TREE
);
2467 se
->string_length
= tmp
;
2470 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2471 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2472 && c
->ts
.type
!= BT_CHARACTER
)
2473 || c
->attr
.proc_pointer
)
2474 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2479 /* This function deals with component references to components of the
2480 parent type for derived type extensions. */
2482 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2490 c
= ref
->u
.c
.component
;
2492 /* Return if the component is in the parent type. */
2493 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2494 if (strcmp (c
->name
, cmp
->name
) == 0)
2497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2498 parent
.type
= REF_COMPONENT
;
2500 parent
.u
.c
.sym
= dt
;
2501 parent
.u
.c
.component
= dt
->components
;
2503 if (dt
->backend_decl
== NULL
)
2504 gfc_get_derived_type (dt
);
2506 /* Build the reference and call self. */
2507 gfc_conv_component_ref (se
, &parent
);
2508 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2509 parent
.u
.c
.component
= c
;
2510 conv_parent_component_references (se
, &parent
);
2515 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2517 tree res
= se
->expr
;
2522 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2523 TREE_TYPE (TREE_TYPE (res
)), res
);
2527 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2528 TREE_TYPE (TREE_TYPE (res
)), res
);
2532 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2537 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2547 /* Return the contents of a variable. Also handles reference/pointer
2548 variables (all Fortran pointer references are implicit). */
2551 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2556 tree parent_decl
= NULL_TREE
;
2559 bool alternate_entry
;
2562 bool first_time
= true;
2564 sym
= expr
->symtree
->n
.sym
;
2565 is_classarray
= IS_CLASS_ARRAY (sym
);
2569 gfc_ss_info
*ss_info
= ss
->info
;
2571 /* Check that something hasn't gone horribly wrong. */
2572 gcc_assert (ss
!= gfc_ss_terminator
);
2573 gcc_assert (ss_info
->expr
== expr
);
2575 /* A scalarized term. We already know the descriptor. */
2576 se
->expr
= ss_info
->data
.array
.descriptor
;
2577 se
->string_length
= ss_info
->string_length
;
2578 ref
= ss_info
->data
.array
.ref
;
2580 gcc_assert (ref
->type
== REF_ARRAY
2581 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2583 gfc_conv_tmp_array_ref (se
);
2587 tree se_expr
= NULL_TREE
;
2589 se
->expr
= gfc_get_symbol_decl (sym
);
2591 /* Deal with references to a parent results or entries by storing
2592 the current_function_decl and moving to the parent_decl. */
2593 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2594 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2595 && sym
->result
== sym
;
2596 entry_master
= sym
->attr
.result
2597 && sym
->ns
->proc_name
->attr
.entry_master
2598 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2599 if (current_function_decl
)
2600 parent_decl
= DECL_CONTEXT (current_function_decl
);
2602 if ((se
->expr
== parent_decl
&& return_value
)
2603 || (sym
->ns
&& sym
->ns
->proc_name
2605 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2606 && (alternate_entry
|| entry_master
)))
2611 /* Special case for assigning the return value of a function.
2612 Self recursive functions must have an explicit return value. */
2613 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2614 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2616 /* Similarly for alternate entry points. */
2617 else if (alternate_entry
2618 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2621 gfc_entry_list
*el
= NULL
;
2623 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2626 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2631 else if (entry_master
2632 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2634 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2639 /* Procedure actual arguments. Look out for temporary variables
2640 with the same attributes as function values. */
2641 else if (!sym
->attr
.temporary
2642 && sym
->attr
.flavor
== FL_PROCEDURE
2643 && se
->expr
!= current_function_decl
)
2645 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2647 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2648 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2654 /* Dereference the expression, where needed. Since characters
2655 are entirely different from other types, they are treated
2657 if (sym
->ts
.type
== BT_CHARACTER
)
2659 /* Dereference character pointer dummy arguments
2661 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2663 || sym
->attr
.function
2664 || sym
->attr
.result
))
2665 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2669 else if (!sym
->attr
.value
)
2671 /* Dereference temporaries for class array dummy arguments. */
2672 if (sym
->attr
.dummy
&& is_classarray
2673 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2675 if (!se
->descriptor_only
)
2676 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2678 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2682 /* Dereference non-character scalar dummy arguments. */
2683 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2684 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2685 && (sym
->ts
.type
!= BT_CLASS
2686 || (!CLASS_DATA (sym
)->attr
.dimension
2687 && !(CLASS_DATA (sym
)->attr
.codimension
2688 && CLASS_DATA (sym
)->attr
.allocatable
))))
2689 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2692 /* Dereference scalar hidden result. */
2693 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2694 && (sym
->attr
.function
|| sym
->attr
.result
)
2695 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2696 && !sym
->attr
.always_explicit
)
2697 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2700 /* Dereference non-character, non-class pointer variables.
2701 These must be dummies, results, or scalars. */
2703 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2704 || gfc_is_associate_pointer (sym
)
2705 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2707 || sym
->attr
.function
2709 || (!sym
->attr
.dimension
2710 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2711 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2713 /* Now treat the class array pointer variables accordingly. */
2714 else if (sym
->ts
.type
== BT_CLASS
2716 && (CLASS_DATA (sym
)->attr
.dimension
2717 || CLASS_DATA (sym
)->attr
.codimension
)
2718 && ((CLASS_DATA (sym
)->as
2719 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2720 || CLASS_DATA (sym
)->attr
.allocatable
2721 || CLASS_DATA (sym
)->attr
.class_pointer
))
2722 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2724 /* And the case where a non-dummy, non-result, non-function,
2725 non-allotable and non-pointer classarray is present. This case was
2726 previously covered by the first if, but with introducing the
2727 condition !is_classarray there, that case has to be covered
2729 else if (sym
->ts
.type
== BT_CLASS
2731 && !sym
->attr
.function
2732 && !sym
->attr
.result
2733 && (CLASS_DATA (sym
)->attr
.dimension
2734 || CLASS_DATA (sym
)->attr
.codimension
)
2736 || !CLASS_DATA (sym
)->attr
.allocatable
)
2737 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2738 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2745 /* For character variables, also get the length. */
2746 if (sym
->ts
.type
== BT_CHARACTER
)
2748 /* If the character length of an entry isn't set, get the length from
2749 the master function instead. */
2750 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2751 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2753 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2754 gcc_assert (se
->string_length
);
2757 gfc_typespec
*ts
= &sym
->ts
;
2763 /* Return the descriptor if that's what we want and this is an array
2764 section reference. */
2765 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2767 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2768 /* Return the descriptor for array pointers and allocations. */
2769 if (se
->want_pointer
2770 && ref
->next
== NULL
&& (se
->descriptor_only
))
2773 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2774 /* Return a pointer to an element. */
2778 ts
= &ref
->u
.c
.component
->ts
;
2779 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2780 && se
->descriptor_only
2781 && !CLASS_DATA (sym
)->attr
.allocatable
2782 && !CLASS_DATA (sym
)->attr
.class_pointer
2783 && CLASS_DATA (sym
)->as
2784 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2785 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2786 /* Skip the first ref of a _data component, because for class
2787 arrays that one is already done by introducing a temporary
2788 array descriptor. */
2791 if (ref
->u
.c
.sym
->attr
.extension
)
2792 conv_parent_component_references (se
, ref
);
2794 gfc_conv_component_ref (se
, ref
);
2795 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2796 && se
->want_pointer
&& se
->descriptor_only
)
2802 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2803 expr
->symtree
->name
, &expr
->where
);
2807 conv_inquiry (se
, ref
, expr
, ts
);
2817 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2819 if (se
->want_pointer
)
2821 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2822 gfc_conv_string_parameter (se
);
2824 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2829 /* Unary ops are easy... Or they would be if ! was a valid op. */
2832 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2837 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2838 /* Initialize the operand. */
2839 gfc_init_se (&operand
, se
);
2840 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2841 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2843 type
= gfc_typenode_for_spec (&expr
->ts
);
2845 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2846 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2847 All other unary operators have an equivalent GIMPLE unary operator. */
2848 if (code
== TRUTH_NOT_EXPR
)
2849 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2850 build_int_cst (type
, 0));
2852 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2856 /* Expand power operator to optimal multiplications when a value is raised
2857 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2858 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2859 Programming", 3rd Edition, 1998. */
2861 /* This code is mostly duplicated from expand_powi in the backend.
2862 We establish the "optimal power tree" lookup table with the defined size.
2863 The items in the table are the exponents used to calculate the index
2864 exponents. Any integer n less than the value can get an "addition chain",
2865 with the first node being one. */
2866 #define POWI_TABLE_SIZE 256
2868 /* The table is from builtins.c. */
2869 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2871 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2872 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2873 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2874 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2875 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2876 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2877 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2878 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2879 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2880 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2881 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2882 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2883 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2884 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2885 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2886 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2887 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2888 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2889 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2890 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2891 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2892 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2893 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2894 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2895 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2896 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2897 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2898 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2899 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2900 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2901 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2902 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2905 /* If n is larger than lookup table's max index, we use the "window
2907 #define POWI_WINDOW_SIZE 3
2909 /* Recursive function to expand the power operator. The temporary
2910 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2912 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2919 if (n
< POWI_TABLE_SIZE
)
2924 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2925 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2929 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2930 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2931 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2935 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2939 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2940 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2942 if (n
< POWI_TABLE_SIZE
)
2949 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2950 return 1. Else return 0 and a call to runtime library functions
2951 will have to be built. */
2953 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2958 tree vartmp
[POWI_TABLE_SIZE
];
2960 unsigned HOST_WIDE_INT n
;
2962 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2964 /* If exponent is too large, we won't expand it anyway, so don't bother
2965 with large integer values. */
2966 if (!wi::fits_shwi_p (wrhs
))
2969 m
= wrhs
.to_shwi ();
2970 /* Use the wide_int's routine to reliably get the absolute value on all
2971 platforms. Then convert it to a HOST_WIDE_INT like above. */
2972 n
= wi::abs (wrhs
).to_shwi ();
2974 type
= TREE_TYPE (lhs
);
2975 sgn
= tree_int_cst_sgn (rhs
);
2977 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2978 || optimize_size
) && (m
> 2 || m
< -1))
2984 se
->expr
= gfc_build_const (type
, integer_one_node
);
2988 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2989 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2991 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2992 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2993 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2994 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2997 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3000 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3001 logical_type_node
, tmp
, cond
);
3002 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3003 tmp
, build_int_cst (type
, 1),
3004 build_int_cst (type
, 0));
3008 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3009 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3010 build_int_cst (type
, -1),
3011 build_int_cst (type
, 0));
3012 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3013 cond
, build_int_cst (type
, 1), tmp
);
3017 memset (vartmp
, 0, sizeof (vartmp
));
3021 tmp
= gfc_build_const (type
, integer_one_node
);
3022 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3026 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3032 /* Power op (**). Constant integer exponent has special handling. */
3035 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3037 tree gfc_int4_type_node
;
3040 int res_ikind_1
, res_ikind_2
;
3045 gfc_init_se (&lse
, se
);
3046 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3047 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3048 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3050 gfc_init_se (&rse
, se
);
3051 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3052 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3054 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3055 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3056 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3059 if (INTEGER_CST_P (lse
.expr
)
3060 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3062 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3064 v
= wlhs
.to_shwi ();
3067 /* 1**something is always 1. */
3068 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3071 else if (v
== 2 || v
== 4 || v
== 8 || v
== 16)
3073 /* 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3074 1<<(4*n), but we have to make sure to return zero if the
3075 number of bits is too large. */
3084 type
= TREE_TYPE (lse
.expr
);
3089 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3090 TREE_TYPE (rse
.expr
),
3091 rse
.expr
, rse
.expr
);
3093 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3094 TREE_TYPE (rse
.expr
),
3095 build_int_cst (TREE_TYPE (rse
.expr
), 3),
3098 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3099 TREE_TYPE (rse
.expr
),
3100 build_int_cst (TREE_TYPE (rse
.expr
), 4),
3105 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3106 build_int_cst (type
, 1), shift
);
3107 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3108 rse
.expr
, build_int_cst (type
, 0));
3109 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3110 build_int_cst (type
, 0));
3111 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3112 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3113 rse
.expr
, num_bits
);
3114 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3115 build_int_cst (type
, 0), cond
);
3120 /* (-1)**n is 1 - ((n & 1) << 1) */
3124 type
= TREE_TYPE (lse
.expr
);
3125 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3126 rse
.expr
, build_int_cst (type
, 1));
3127 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3128 tmp
, build_int_cst (type
, 1));
3129 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3130 build_int_cst (type
, 1), tmp
);
3136 gfc_int4_type_node
= gfc_get_int_type (4);
3138 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3139 library routine. But in the end, we have to convert the result back
3140 if this case applies -- with res_ikind_K, we keep track whether operand K
3141 falls into this case. */
3145 kind
= expr
->value
.op
.op1
->ts
.kind
;
3146 switch (expr
->value
.op
.op2
->ts
.type
)
3149 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3154 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3155 res_ikind_2
= ikind
;
3177 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3179 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3206 switch (expr
->value
.op
.op1
->ts
.type
)
3209 if (kind
== 3) /* Case 16 was not handled properly above. */
3211 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3215 /* Use builtins for real ** int4. */
3221 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3225 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3229 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3233 /* Use the __builtin_powil() only if real(kind=16) is
3234 actually the C long double type. */
3235 if (!gfc_real16_is_float128
)
3236 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3244 /* If we don't have a good builtin for this, go for the
3245 library function. */
3247 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3251 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3260 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3264 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3272 se
->expr
= build_call_expr_loc (input_location
,
3273 fndecl
, 2, lse
.expr
, rse
.expr
);
3275 /* Convert the result back if it is of wrong integer kind. */
3276 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3278 /* We want the maximum of both operand kinds as result. */
3279 if (res_ikind_1
< res_ikind_2
)
3280 res_ikind_1
= res_ikind_2
;
3281 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3286 /* Generate code to allocate a string temporary. */
3289 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3294 if (gfc_can_put_var_on_stack (len
))
3296 /* Create a temporary variable to hold the result. */
3297 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3298 TREE_TYPE (len
), len
,
3299 build_int_cst (TREE_TYPE (len
), 1));
3300 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3302 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3303 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3305 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3307 var
= gfc_create_var (tmp
, "str");
3308 var
= gfc_build_addr_expr (type
, var
);
3312 /* Allocate a temporary to hold the result. */
3313 var
= gfc_create_var (type
, "pstr");
3314 gcc_assert (POINTER_TYPE_P (type
));
3315 tmp
= TREE_TYPE (type
);
3316 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3317 tmp
= TREE_TYPE (tmp
);
3318 tmp
= TYPE_SIZE_UNIT (tmp
);
3319 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3320 fold_convert (size_type_node
, len
),
3321 fold_convert (size_type_node
, tmp
));
3322 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3323 gfc_add_modify (&se
->pre
, var
, tmp
);
3325 /* Free the temporary afterwards. */
3326 tmp
= gfc_call_free (var
);
3327 gfc_add_expr_to_block (&se
->post
, tmp
);
3334 /* Handle a string concatenation operation. A temporary will be allocated to
3338 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3341 tree len
, type
, var
, tmp
, fndecl
;
3343 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3344 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3345 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3347 gfc_init_se (&lse
, se
);
3348 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3349 gfc_conv_string_parameter (&lse
);
3350 gfc_init_se (&rse
, se
);
3351 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3352 gfc_conv_string_parameter (&rse
);
3354 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3355 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3357 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3358 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3359 if (len
== NULL_TREE
)
3361 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3362 gfc_charlen_type_node
,
3363 fold_convert (gfc_charlen_type_node
,
3365 fold_convert (gfc_charlen_type_node
,
3366 rse
.string_length
));
3369 type
= build_pointer_type (type
);
3371 var
= gfc_conv_string_tmp (se
, type
, len
);
3373 /* Do the actual concatenation. */
3374 if (expr
->ts
.kind
== 1)
3375 fndecl
= gfor_fndecl_concat_string
;
3376 else if (expr
->ts
.kind
== 4)
3377 fndecl
= gfor_fndecl_concat_string_char4
;
3381 tmp
= build_call_expr_loc (input_location
,
3382 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3383 rse
.string_length
, rse
.expr
);
3384 gfc_add_expr_to_block (&se
->pre
, tmp
);
3386 /* Add the cleanup for the operands. */
3387 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3388 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3391 se
->string_length
= len
;
3394 /* Translates an op expression. Common (binary) cases are handled by this
3395 function, others are passed on. Recursion is used in either case.
3396 We use the fact that (op1.ts == op2.ts) (except for the power
3398 Operators need no special handling for scalarized expressions as long as
3399 they call gfc_conv_simple_val to get their operands.
3400 Character strings get special handling. */
3403 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3405 enum tree_code code
;
3414 switch (expr
->value
.op
.op
)
3416 case INTRINSIC_PARENTHESES
:
3417 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3418 && flag_protect_parens
)
3420 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3421 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3426 case INTRINSIC_UPLUS
:
3427 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3430 case INTRINSIC_UMINUS
:
3431 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3435 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3438 case INTRINSIC_PLUS
:
3442 case INTRINSIC_MINUS
:
3446 case INTRINSIC_TIMES
:
3450 case INTRINSIC_DIVIDE
:
3451 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3452 an integer, we must round towards zero, so we use a
3454 if (expr
->ts
.type
== BT_INTEGER
)
3455 code
= TRUNC_DIV_EXPR
;
3460 case INTRINSIC_POWER
:
3461 gfc_conv_power_op (se
, expr
);
3464 case INTRINSIC_CONCAT
:
3465 gfc_conv_concat_op (se
, expr
);
3469 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3474 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3478 /* EQV and NEQV only work on logicals, but since we represent them
3479 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3481 case INTRINSIC_EQ_OS
:
3489 case INTRINSIC_NE_OS
:
3490 case INTRINSIC_NEQV
:
3497 case INTRINSIC_GT_OS
:
3504 case INTRINSIC_GE_OS
:
3511 case INTRINSIC_LT_OS
:
3518 case INTRINSIC_LE_OS
:
3524 case INTRINSIC_USER
:
3525 case INTRINSIC_ASSIGN
:
3526 /* These should be converted into function calls by the frontend. */
3530 fatal_error (input_location
, "Unknown intrinsic op");
3534 /* The only exception to this is **, which is handled separately anyway. */
3535 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3537 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3541 gfc_init_se (&lse
, se
);
3542 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3543 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3546 gfc_init_se (&rse
, se
);
3547 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3548 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3552 gfc_conv_string_parameter (&lse
);
3553 gfc_conv_string_parameter (&rse
);
3555 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3556 rse
.string_length
, rse
.expr
,
3557 expr
->value
.op
.op1
->ts
.kind
,
3559 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3560 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3563 type
= gfc_typenode_for_spec (&expr
->ts
);
3567 /* The result of logical ops is always logical_type_node. */
3568 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3569 lse
.expr
, rse
.expr
);
3570 se
->expr
= convert (type
, tmp
);
3573 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3575 /* Add the post blocks. */
3576 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3577 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3580 /* If a string's length is one, we convert it to a single character. */
3583 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3587 || !tree_fits_uhwi_p (len
)
3588 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3591 if (TREE_INT_CST_LOW (len
) == 1)
3593 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3594 return build_fold_indirect_ref_loc (input_location
, str
);
3598 && TREE_CODE (str
) == ADDR_EXPR
3599 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3600 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3601 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3602 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3603 && TREE_INT_CST_LOW (len
) > 1
3604 && TREE_INT_CST_LOW (len
)
3605 == (unsigned HOST_WIDE_INT
)
3606 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3608 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3609 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3610 if (TREE_CODE (ret
) == INTEGER_CST
)
3612 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3613 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3614 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3616 for (i
= 1; i
< length
; i
++)
3629 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3632 if (sym
->backend_decl
)
3634 /* This becomes the nominal_type in
3635 function.c:assign_parm_find_data_types. */
3636 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3637 /* This becomes the passed_type in
3638 function.c:assign_parm_find_data_types. C promotes char to
3639 integer for argument passing. */
3640 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3642 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3647 /* If we have a constant character expression, make it into an
3649 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3654 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3655 (int)(*expr
)->value
.character
.string
[0]);
3656 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3658 /* The expr needs to be compatible with a C int. If the
3659 conversion fails, then the 2 causes an ICE. */
3660 ts
.type
= BT_INTEGER
;
3661 ts
.kind
= gfc_c_int_kind
;
3662 gfc_convert_type (*expr
, &ts
, 2);
3665 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3667 if ((*expr
)->ref
== NULL
)
3669 se
->expr
= gfc_string_to_single_character
3670 (build_int_cst (integer_type_node
, 1),
3671 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3673 ((*expr
)->symtree
->n
.sym
)),
3678 gfc_conv_variable (se
, *expr
);
3679 se
->expr
= gfc_string_to_single_character
3680 (build_int_cst (integer_type_node
, 1),
3681 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3689 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3690 if STR is a string literal, otherwise return -1. */
3693 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3696 && TREE_CODE (str
) == ADDR_EXPR
3697 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3698 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3699 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3700 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3701 && tree_fits_uhwi_p (len
)
3702 && tree_to_uhwi (len
) >= 1
3703 && tree_to_uhwi (len
)
3704 == (unsigned HOST_WIDE_INT
)
3705 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3707 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3708 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3709 if (TREE_CODE (folded
) == INTEGER_CST
)
3711 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3712 int length
= TREE_STRING_LENGTH (string_cst
);
3713 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3715 for (; length
> 0; length
--)
3716 if (ptr
[length
- 1] != ' ')
3725 /* Helper to build a call to memcmp. */
3728 build_memcmp_call (tree s1
, tree s2
, tree n
)
3732 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3733 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3735 s1
= fold_convert (pvoid_type_node
, s1
);
3737 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3738 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3740 s2
= fold_convert (pvoid_type_node
, s2
);
3742 n
= fold_convert (size_type_node
, n
);
3744 tmp
= build_call_expr_loc (input_location
,
3745 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3748 return fold_convert (integer_type_node
, tmp
);
3751 /* Compare two strings. If they are all single characters, the result is the
3752 subtraction of them. Otherwise, we build a library call. */
3755 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3756 enum tree_code code
)
3762 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3763 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3765 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3766 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3768 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3770 /* Deal with single character specially. */
3771 sc1
= fold_convert (integer_type_node
, sc1
);
3772 sc2
= fold_convert (integer_type_node
, sc2
);
3773 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3777 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3779 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3781 /* If one string is a string literal with LEN_TRIM longer
3782 than the length of the second string, the strings
3784 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3785 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3786 return integer_one_node
;
3787 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3788 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3789 return integer_one_node
;
3792 /* We can compare via memcpy if the strings are known to be equal
3793 in length and they are
3795 - kind=4 and the comparison is for (in)equality. */
3797 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3798 && tree_int_cst_equal (len1
, len2
)
3799 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3804 chartype
= gfc_get_char_type (kind
);
3805 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3806 fold_convert (TREE_TYPE(len1
),
3807 TYPE_SIZE_UNIT(chartype
)),
3809 return build_memcmp_call (str1
, str2
, tmp
);
3812 /* Build a call for the comparison. */
3814 fndecl
= gfor_fndecl_compare_string
;
3816 fndecl
= gfor_fndecl_compare_string_char4
;
3820 return build_call_expr_loc (input_location
, fndecl
, 4,
3821 len1
, str1
, len2
, str2
);
3825 /* Return the backend_decl for a procedure pointer component. */
3828 get_proc_ptr_comp (gfc_expr
*e
)
3834 gfc_init_se (&comp_se
, NULL
);
3835 e2
= gfc_copy_expr (e
);
3836 /* We have to restore the expr type later so that gfc_free_expr frees
3837 the exact same thing that was allocated.
3838 TODO: This is ugly. */
3839 old_type
= e2
->expr_type
;
3840 e2
->expr_type
= EXPR_VARIABLE
;
3841 gfc_conv_expr (&comp_se
, e2
);
3842 e2
->expr_type
= old_type
;
3844 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3848 /* Convert a typebound function reference from a class object. */
3850 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3855 if (!VAR_P (base_object
))
3857 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3858 gfc_add_modify (&se
->pre
, var
, base_object
);
3860 se
->expr
= gfc_class_vptr_get (base_object
);
3861 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3863 while (ref
&& ref
->next
)
3865 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3866 if (ref
->u
.c
.sym
->attr
.extension
)
3867 conv_parent_component_references (se
, ref
);
3868 gfc_conv_component_ref (se
, ref
);
3869 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3874 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3878 if (gfc_is_proc_ptr_comp (expr
))
3879 tmp
= get_proc_ptr_comp (expr
);
3880 else if (sym
->attr
.dummy
)
3882 tmp
= gfc_get_symbol_decl (sym
);
3883 if (sym
->attr
.proc_pointer
)
3884 tmp
= build_fold_indirect_ref_loc (input_location
,
3886 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3887 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3891 if (!sym
->backend_decl
)
3892 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3894 TREE_USED (sym
->backend_decl
) = 1;
3896 tmp
= sym
->backend_decl
;
3898 if (sym
->attr
.cray_pointee
)
3900 /* TODO - make the cray pointee a pointer to a procedure,
3901 assign the pointer to it and use it for the call. This
3903 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3904 gfc_get_symbol_decl (sym
->cp_pointer
));
3905 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3908 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3910 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3911 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3918 /* Initialize MAPPING. */
3921 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3923 mapping
->syms
= NULL
;
3924 mapping
->charlens
= NULL
;
3928 /* Free all memory held by MAPPING (but not MAPPING itself). */
3931 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3933 gfc_interface_sym_mapping
*sym
;
3934 gfc_interface_sym_mapping
*nextsym
;
3936 gfc_charlen
*nextcl
;
3938 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3940 nextsym
= sym
->next
;
3941 sym
->new_sym
->n
.sym
->formal
= NULL
;
3942 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3943 gfc_free_expr (sym
->expr
);
3944 free (sym
->new_sym
);
3947 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3950 gfc_free_expr (cl
->length
);
3956 /* Return a copy of gfc_charlen CL. Add the returned structure to
3957 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3959 static gfc_charlen
*
3960 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3963 gfc_charlen
*new_charlen
;
3965 new_charlen
= gfc_get_charlen ();
3966 new_charlen
->next
= mapping
->charlens
;
3967 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3969 mapping
->charlens
= new_charlen
;
3974 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3975 array variable that can be used as the actual argument for dummy
3976 argument SYM. Add any initialization code to BLOCK. PACKED is as
3977 for gfc_get_nodesc_array_type and DATA points to the first element
3978 in the passed array. */
3981 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3982 gfc_packed packed
, tree data
)
3987 type
= gfc_typenode_for_spec (&sym
->ts
);
3988 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3989 !sym
->attr
.target
&& !sym
->attr
.pointer
3990 && !sym
->attr
.proc_pointer
);
3992 var
= gfc_create_var (type
, "ifm");
3993 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3999 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4000 and offset of descriptorless array type TYPE given that it has the same
4001 size as DESC. Add any set-up code to BLOCK. */
4004 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4011 offset
= gfc_index_zero_node
;
4012 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4014 dim
= gfc_rank_cst
[n
];
4015 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4016 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4018 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4019 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4020 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4021 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4023 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4025 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4026 gfc_array_index_type
,
4027 gfc_conv_descriptor_ubound_get (desc
, dim
),
4028 gfc_conv_descriptor_lbound_get (desc
, dim
));
4029 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4030 gfc_array_index_type
,
4031 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4032 tmp
= gfc_evaluate_now (tmp
, block
);
4033 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4035 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4036 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4037 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4038 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4039 gfc_array_index_type
, offset
, tmp
);
4041 offset
= gfc_evaluate_now (offset
, block
);
4042 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4046 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4047 in SE. The caller may still use se->expr and se->string_length after
4048 calling this function. */
4051 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4052 gfc_symbol
* sym
, gfc_se
* se
,
4055 gfc_interface_sym_mapping
*sm
;
4059 gfc_symbol
*new_sym
;
4061 gfc_symtree
*new_symtree
;
4063 /* Create a new symbol to represent the actual argument. */
4064 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4065 new_sym
->ts
= sym
->ts
;
4066 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4067 new_sym
->attr
.referenced
= 1;
4068 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4069 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4070 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4071 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4072 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4073 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4074 new_sym
->attr
.function
= sym
->attr
.function
;
4076 /* Ensure that the interface is available and that
4077 descriptors are passed for array actual arguments. */
4078 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4080 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4081 new_sym
->attr
.always_explicit
4082 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4085 /* Create a fake symtree for it. */
4087 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4088 new_symtree
->n
.sym
= new_sym
;
4089 gcc_assert (new_symtree
== root
);
4091 /* Create a dummy->actual mapping. */
4092 sm
= XCNEW (gfc_interface_sym_mapping
);
4093 sm
->next
= mapping
->syms
;
4095 sm
->new_sym
= new_symtree
;
4096 sm
->expr
= gfc_copy_expr (expr
);
4099 /* Stabilize the argument's value. */
4100 if (!sym
->attr
.function
&& se
)
4101 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4103 if (sym
->ts
.type
== BT_CHARACTER
)
4105 /* Create a copy of the dummy argument's length. */
4106 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4107 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4109 /* If the length is specified as "*", record the length that
4110 the caller is passing. We should use the callee's length
4111 in all other cases. */
4112 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4114 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4115 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4122 /* Use the passed value as-is if the argument is a function. */
4123 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4126 /* If the argument is a pass-by-value scalar, use the value as is. */
4127 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4130 /* If the argument is either a string or a pointer to a string,
4131 convert it to a boundless character type. */
4132 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4134 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4135 tmp
= build_pointer_type (tmp
);
4136 if (sym
->attr
.pointer
)
4137 value
= build_fold_indirect_ref_loc (input_location
,
4141 value
= fold_convert (tmp
, value
);
4144 /* If the argument is a scalar, a pointer to an array or an allocatable,
4146 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4147 value
= build_fold_indirect_ref_loc (input_location
,
4150 /* For character(*), use the actual argument's descriptor. */
4151 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4152 value
= build_fold_indirect_ref_loc (input_location
,
4155 /* If the argument is an array descriptor, use it to determine
4156 information about the actual argument's shape. */
4157 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4158 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4160 /* Get the actual argument's descriptor. */
4161 desc
= build_fold_indirect_ref_loc (input_location
,
4164 /* Create the replacement variable. */
4165 tmp
= gfc_conv_descriptor_data_get (desc
);
4166 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4169 /* Use DESC to work out the upper bounds, strides and offset. */
4170 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4173 /* Otherwise we have a packed array. */
4174 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4175 PACKED_FULL
, se
->expr
);
4177 new_sym
->backend_decl
= value
;
4181 /* Called once all dummy argument mappings have been added to MAPPING,
4182 but before the mapping is used to evaluate expressions. Pre-evaluate
4183 the length of each argument, adding any initialization code to PRE and
4184 any finalization code to POST. */
4187 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4188 stmtblock_t
* pre
, stmtblock_t
* post
)
4190 gfc_interface_sym_mapping
*sym
;
4194 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4195 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4196 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4198 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4199 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4200 gfc_init_se (&se
, NULL
);
4201 gfc_conv_expr (&se
, expr
);
4202 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4203 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4204 gfc_add_block_to_block (pre
, &se
.pre
);
4205 gfc_add_block_to_block (post
, &se
.post
);
4207 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4212 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4216 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4217 gfc_constructor_base base
)
4220 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4222 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4225 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4226 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4227 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4233 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4237 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4242 for (; ref
; ref
= ref
->next
)
4246 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4248 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4249 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4250 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4259 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4260 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4266 /* Convert intrinsic function calls into result expressions. */
4269 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4277 arg1
= expr
->value
.function
.actual
->expr
;
4278 if (expr
->value
.function
.actual
->next
)
4279 arg2
= expr
->value
.function
.actual
->next
->expr
;
4283 sym
= arg1
->symtree
->n
.sym
;
4285 if (sym
->attr
.dummy
)
4290 switch (expr
->value
.function
.isym
->id
)
4293 /* TODO figure out why this condition is necessary. */
4294 if (sym
->attr
.function
4295 && (arg1
->ts
.u
.cl
->length
== NULL
4296 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4297 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4300 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4303 case GFC_ISYM_LEN_TRIM
:
4304 new_expr
= gfc_copy_expr (arg1
);
4305 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4310 gfc_replace_expr (arg1
, new_expr
);
4314 if (!sym
->as
|| sym
->as
->rank
== 0)
4317 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4319 dup
= mpz_get_si (arg2
->value
.integer
);
4324 dup
= sym
->as
->rank
;
4328 for (; d
< dup
; d
++)
4332 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4334 gfc_free_expr (new_expr
);
4338 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4339 gfc_get_int_expr (gfc_default_integer_kind
,
4341 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4343 new_expr
= gfc_multiply (new_expr
, tmp
);
4349 case GFC_ISYM_LBOUND
:
4350 case GFC_ISYM_UBOUND
:
4351 /* TODO These implementations of lbound and ubound do not limit if
4352 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4354 if (!sym
->as
|| sym
->as
->rank
== 0)
4357 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4358 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4362 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4364 if (sym
->as
->lower
[d
])
4365 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4369 if (sym
->as
->upper
[d
])
4370 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4378 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4382 gfc_replace_expr (expr
, new_expr
);
4388 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4389 gfc_interface_mapping
* mapping
)
4391 gfc_formal_arglist
*f
;
4392 gfc_actual_arglist
*actual
;
4394 actual
= expr
->value
.function
.actual
;
4395 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4397 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4402 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4405 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4410 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4412 for (d
= 0; d
< as
->rank
; d
++)
4414 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4415 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4418 expr
->value
.function
.esym
->as
= as
;
4421 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4423 expr
->value
.function
.esym
->ts
.u
.cl
->length
4424 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4426 gfc_apply_interface_mapping_to_expr (mapping
,
4427 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4432 /* EXPR is a copy of an expression that appeared in the interface
4433 associated with MAPPING. Walk it recursively looking for references to
4434 dummy arguments that MAPPING maps to actual arguments. Replace each such
4435 reference with a reference to the associated actual argument. */
4438 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4441 gfc_interface_sym_mapping
*sym
;
4442 gfc_actual_arglist
*actual
;
4447 /* Copying an expression does not copy its length, so do that here. */
4448 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4450 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4451 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4454 /* Apply the mapping to any references. */
4455 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4457 /* ...and to the expression's symbol, if it has one. */
4458 /* TODO Find out why the condition on expr->symtree had to be moved into
4459 the loop rather than being outside it, as originally. */
4460 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4461 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4463 if (sym
->new_sym
->n
.sym
->backend_decl
)
4464 expr
->symtree
= sym
->new_sym
;
4466 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4469 /* ...and to subexpressions in expr->value. */
4470 switch (expr
->expr_type
)
4475 case EXPR_SUBSTRING
:
4479 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4480 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4484 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4485 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4487 if (expr
->value
.function
.esym
== NULL
4488 && expr
->value
.function
.isym
!= NULL
4489 && expr
->value
.function
.actual
4490 && expr
->value
.function
.actual
->expr
4491 && expr
->value
.function
.actual
->expr
->symtree
4492 && gfc_map_intrinsic_function (expr
, mapping
))
4495 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4496 if (sym
->old
== expr
->value
.function
.esym
)
4498 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4499 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4500 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4505 case EXPR_STRUCTURE
:
4506 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4519 /* Evaluate interface expression EXPR using MAPPING. Store the result
4523 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4524 gfc_se
* se
, gfc_expr
* expr
)
4526 expr
= gfc_copy_expr (expr
);
4527 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4528 gfc_conv_expr (se
, expr
);
4529 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4530 gfc_free_expr (expr
);
4534 /* Returns a reference to a temporary array into which a component of
4535 an actual argument derived type array is copied and then returned
4536 after the function call. */
4538 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4539 sym_intent intent
, bool formal_ptr
)
4547 gfc_array_info
*info
;
4557 gfc_init_se (&lse
, NULL
);
4558 gfc_init_se (&rse
, NULL
);
4560 /* Walk the argument expression. */
4561 rss
= gfc_walk_expr (expr
);
4563 gcc_assert (rss
!= gfc_ss_terminator
);
4565 /* Initialize the scalarizer. */
4566 gfc_init_loopinfo (&loop
);
4567 gfc_add_ss_to_loop (&loop
, rss
);
4569 /* Calculate the bounds of the scalarization. */
4570 gfc_conv_ss_startstride (&loop
);
4572 /* Build an ss for the temporary. */
4573 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4574 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4576 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4577 if (GFC_ARRAY_TYPE_P (base_type
)
4578 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4579 base_type
= gfc_get_element_type (base_type
);
4581 if (expr
->ts
.type
== BT_CLASS
)
4582 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4584 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4585 ? expr
->ts
.u
.cl
->backend_decl
4589 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4591 /* Associate the SS with the loop. */
4592 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4594 /* Setup the scalarizing loops. */
4595 gfc_conv_loop_setup (&loop
, &expr
->where
);
4597 /* Pass the temporary descriptor back to the caller. */
4598 info
= &loop
.temp_ss
->info
->data
.array
;
4599 parmse
->expr
= info
->descriptor
;
4601 /* Setup the gfc_se structures. */
4602 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4603 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4606 lse
.ss
= loop
.temp_ss
;
4607 gfc_mark_ss_chain_used (rss
, 1);
4608 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4610 /* Start the scalarized loop body. */
4611 gfc_start_scalarized_body (&loop
, &body
);
4613 /* Translate the expression. */
4614 gfc_conv_expr (&rse
, expr
);
4616 /* Reset the offset for the function call since the loop
4617 is zero based on the data pointer. Note that the temp
4618 comes first in the loop chain since it is added second. */
4619 if (gfc_is_class_array_function (expr
))
4621 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4622 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4623 gfc_index_zero_node
);
4626 gfc_conv_tmp_array_ref (&lse
);
4628 if (intent
!= INTENT_OUT
)
4630 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4631 gfc_add_expr_to_block (&body
, tmp
);
4632 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4633 gfc_trans_scalarizing_loops (&loop
, &body
);
4637 /* Make sure that the temporary declaration survives by merging
4638 all the loop declarations into the current context. */
4639 for (n
= 0; n
< loop
.dimen
; n
++)
4641 gfc_merge_block_scope (&body
);
4642 body
= loop
.code
[loop
.order
[n
]];
4644 gfc_merge_block_scope (&body
);
4647 /* Add the post block after the second loop, so that any
4648 freeing of allocated memory is done at the right time. */
4649 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4651 /**********Copy the temporary back again.*********/
4653 gfc_init_se (&lse
, NULL
);
4654 gfc_init_se (&rse
, NULL
);
4656 /* Walk the argument expression. */
4657 lss
= gfc_walk_expr (expr
);
4658 rse
.ss
= loop
.temp_ss
;
4661 /* Initialize the scalarizer. */
4662 gfc_init_loopinfo (&loop2
);
4663 gfc_add_ss_to_loop (&loop2
, lss
);
4665 dimen
= rse
.ss
->dimen
;
4667 /* Skip the write-out loop for this case. */
4668 if (gfc_is_class_array_function (expr
))
4669 goto class_array_fcn
;
4671 /* Calculate the bounds of the scalarization. */
4672 gfc_conv_ss_startstride (&loop2
);
4674 /* Setup the scalarizing loops. */
4675 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4677 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4678 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4680 gfc_mark_ss_chain_used (lss
, 1);
4681 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4683 /* Declare the variable to hold the temporary offset and start the
4684 scalarized loop body. */
4685 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4686 gfc_start_scalarized_body (&loop2
, &body
);
4688 /* Build the offsets for the temporary from the loop variables. The
4689 temporary array has lbounds of zero and strides of one in all
4690 dimensions, so this is very simple. The offset is only computed
4691 outside the innermost loop, so the overall transfer could be
4692 optimized further. */
4693 info
= &rse
.ss
->info
->data
.array
;
4695 tmp_index
= gfc_index_zero_node
;
4696 for (n
= dimen
- 1; n
> 0; n
--)
4699 tmp
= rse
.loop
->loopvar
[n
];
4700 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4701 tmp
, rse
.loop
->from
[n
]);
4702 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4705 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4706 gfc_array_index_type
,
4707 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4708 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4709 gfc_array_index_type
,
4710 tmp_str
, gfc_index_one_node
);
4712 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4713 gfc_array_index_type
, tmp
, tmp_str
);
4716 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4717 gfc_array_index_type
,
4718 tmp_index
, rse
.loop
->from
[0]);
4719 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4721 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4722 gfc_array_index_type
,
4723 rse
.loop
->loopvar
[0], offset
);
4725 /* Now use the offset for the reference. */
4726 tmp
= build_fold_indirect_ref_loc (input_location
,
4728 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4730 if (expr
->ts
.type
== BT_CHARACTER
)
4731 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4733 gfc_conv_expr (&lse
, expr
);
4735 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4737 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4738 gfc_add_expr_to_block (&body
, tmp
);
4740 /* Generate the copying loops. */
4741 gfc_trans_scalarizing_loops (&loop2
, &body
);
4743 /* Wrap the whole thing up by adding the second loop to the post-block
4744 and following it by the post-block of the first loop. In this way,
4745 if the temporary needs freeing, it is done after use! */
4746 if (intent
!= INTENT_IN
)
4748 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4749 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4754 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4756 gfc_cleanup_loop (&loop
);
4757 gfc_cleanup_loop (&loop2
);
4759 /* Pass the string length to the argument expression. */
4760 if (expr
->ts
.type
== BT_CHARACTER
)
4761 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4763 /* Determine the offset for pointer formal arguments and set the
4767 size
= gfc_index_one_node
;
4768 offset
= gfc_index_zero_node
;
4769 for (n
= 0; n
< dimen
; n
++)
4771 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4774 gfc_array_index_type
, tmp
,
4775 gfc_index_one_node
);
4776 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4780 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4783 gfc_index_one_node
);
4784 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4785 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4786 gfc_array_index_type
,
4788 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4789 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4790 gfc_array_index_type
,
4791 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4792 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4793 gfc_array_index_type
,
4794 tmp
, gfc_index_one_node
);
4795 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4796 gfc_array_index_type
, size
, tmp
);
4799 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4803 /* We want either the address for the data or the address of the descriptor,
4804 depending on the mode of passing array arguments. */
4806 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4808 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4814 /* Generate the code for argument list functions. */
4817 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4819 /* Pass by value for g77 %VAL(arg), pass the address
4820 indirectly for %LOC, else by reference. Thus %REF
4821 is a "do-nothing" and %LOC is the same as an F95
4823 if (strcmp (name
, "%VAL") == 0)
4824 gfc_conv_expr (se
, expr
);
4825 else if (strcmp (name
, "%LOC") == 0)
4827 gfc_conv_expr_reference (se
, expr
);
4828 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4830 else if (strcmp (name
, "%REF") == 0)
4831 gfc_conv_expr_reference (se
, expr
);
4833 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4837 /* This function tells whether the middle-end representation of the expression
4838 E given as input may point to data otherwise accessible through a variable
4840 It is assumed that the only expressions that may alias are variables,
4841 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4843 This function is used to decide whether freeing an expression's allocatable
4844 components is safe or should be avoided.
4846 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4847 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4848 is necessary because for array constructors, aliasing depends on how
4850 - If E is an array constructor used as argument to an elemental procedure,
4851 the array, which is generated through shallow copy by the scalarizer,
4852 is used directly and can alias the expressions it was copied from.
4853 - If E is an array constructor used as argument to a non-elemental
4854 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4855 the array as in the previous case, but then that array is used
4856 to initialize a new descriptor through deep copy. There is no alias
4857 possible in that case.
4858 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4862 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4866 if (e
->expr_type
== EXPR_VARIABLE
)
4868 else if (e
->expr_type
== EXPR_FUNCTION
)
4870 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4872 if (proc_ifc
->result
!= NULL
4873 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4874 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4875 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4876 || proc_ifc
->result
->attr
.pointer
))
4881 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4884 for (c
= gfc_constructor_first (e
->value
.constructor
);
4885 c
; c
= gfc_constructor_next (c
))
4887 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4894 /* Provide an interface between gfortran array descriptors and the F2018:18.4
4895 ISO_Fortran_binding array descriptors. */
4898 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
4905 symbol_attribute attr
= gfc_expr_attr (e
);
4907 /* If this is a full array or a scalar, the allocatable and pointer
4908 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
4910 if (!e
->rank
|| gfc_get_full_arrayspec_from_expr (e
))
4914 else if (attr
.allocatable
)
4920 gfc_conv_expr_descriptor (parmse
, e
);
4922 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
4923 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
4926 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
4927 the expression type is different from the descriptor type, then
4928 the offset must be found (eg. to a component ref or substring)
4929 and the dtype updated. */
4930 type
= gfc_typenode_for_spec (&e
->ts
);
4931 if (DECL_ARTIFICIAL (parmse
->expr
)
4932 && type
!= gfc_get_element_type (TREE_TYPE (parmse
->expr
)))
4934 /* Obtain the offset to the data. */
4935 gfc_get_dataptr_offset (&parmse
->pre
, parmse
->expr
, parmse
->expr
,
4936 gfc_index_zero_node
, true, e
);
4938 /* Update the dtype. */
4939 gfc_add_modify (&parmse
->pre
,
4940 gfc_conv_descriptor_dtype (parmse
->expr
),
4941 gfc_get_dtype_rank_type (e
->rank
, type
));
4943 else if (!is_subref_array (e
) && !DECL_ARTIFICIAL (parmse
->expr
))
4945 /* Make sure that the span is set for expressions where it
4946 might not have been done already. */
4947 tmp
= TREE_TYPE (parmse
->expr
);
4948 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
4949 tmp
= fold_convert (gfc_array_index_type
, tmp
);
4950 gfc_conv_descriptor_span_set (&parmse
->pre
, parmse
->expr
, tmp
);
4955 gfc_conv_expr (parmse
, e
);
4957 if (POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
4958 parmse
->expr
= build_fold_indirect_ref_loc (input_location
,
4961 /* Copy the scalar for INTENT_IN. */
4962 if (e
->expr_type
== EXPR_VARIABLE
&& fsym
->attr
.intent
== INTENT_IN
)
4963 parmse
->expr
= gfc_evaluate_now (parmse
->expr
, &parmse
->pre
);
4964 parmse
->expr
= gfc_conv_scalar_to_descriptor (parmse
,
4965 parmse
->expr
, attr
);
4968 /* Set the CFI attribute field. */
4969 tmp
= gfc_conv_descriptor_attribute (parmse
->expr
);
4970 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4971 void_type_node
, tmp
,
4972 build_int_cst (TREE_TYPE (tmp
), attribute
));
4973 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
4975 /* Now pass the gfc_descriptor by reference. */
4976 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4978 /* Variables to point to the gfc and CFI descriptors. */
4979 gfc_desc_ptr
= parmse
->expr
;
4980 cfi_desc_ptr
= gfc_create_var (pvoid_type_node
, "cfi");
4982 /* Allocate the CFI descriptor and fill the fields. */
4983 tmp
= gfc_build_addr_expr (NULL_TREE
, cfi_desc_ptr
);
4984 tmp
= build_call_expr_loc (input_location
,
4985 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
4986 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
4988 /* The CFI descriptor is passed to the bind_C procedure. */
4989 parmse
->expr
= cfi_desc_ptr
;
4991 /* Transfer values back to gfc descriptor and free the CFI descriptor. */
4992 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4993 tmp
= build_call_expr_loc (input_location
,
4994 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
4995 gfc_prepend_expr_to_block (&parmse
->post
, tmp
);
4999 /* Generate code for a procedure call. Note can return se->post != NULL.
5000 If se->direct_byref is set then se->expr contains the return parameter.
5001 Return nonzero, if the call has alternate specifiers.
5002 'expr' is only needed for procedure pointer components. */
5005 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5006 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5007 vec
<tree
, va_gc
> *append_args
)
5009 gfc_interface_mapping mapping
;
5010 vec
<tree
, va_gc
> *arglist
;
5011 vec
<tree
, va_gc
> *retargs
;
5015 gfc_array_info
*info
;
5022 vec
<tree
, va_gc
> *stringargs
;
5023 vec
<tree
, va_gc
> *optionalargs
;
5025 gfc_formal_arglist
*formal
;
5026 gfc_actual_arglist
*arg
;
5027 int has_alternate_specifier
= 0;
5028 bool need_interface_mapping
;
5036 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
5037 gfc_component
*comp
= NULL
;
5044 optionalargs
= NULL
;
5049 comp
= gfc_get_proc_ptr_comp (expr
);
5051 bool elemental_proc
= (comp
5052 && comp
->ts
.interface
5053 && comp
->ts
.interface
->attr
.elemental
)
5054 || (comp
&& comp
->attr
.elemental
)
5055 || sym
->attr
.elemental
;
5059 if (!elemental_proc
)
5061 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
5062 if (se
->ss
->info
->useflags
)
5064 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
5065 && sym
->result
->attr
.dimension
)
5066 || (comp
&& comp
->attr
.dimension
)
5067 || gfc_is_class_array_function (expr
));
5068 gcc_assert (se
->loop
!= NULL
);
5069 /* Access the previously obtained result. */
5070 gfc_conv_tmp_array_ref (se
);
5074 info
= &se
->ss
->info
->data
.array
;
5079 gfc_init_block (&post
);
5080 gfc_init_interface_mapping (&mapping
);
5083 formal
= gfc_sym_get_dummy_args (sym
);
5084 need_interface_mapping
= sym
->attr
.dimension
||
5085 (sym
->ts
.type
== BT_CHARACTER
5086 && sym
->ts
.u
.cl
->length
5087 && sym
->ts
.u
.cl
->length
->expr_type
5092 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
5093 need_interface_mapping
= comp
->attr
.dimension
||
5094 (comp
->ts
.type
== BT_CHARACTER
5095 && comp
->ts
.u
.cl
->length
5096 && comp
->ts
.u
.cl
->length
->expr_type
5100 base_object
= NULL_TREE
;
5101 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5102 is the third and fourth argument to such a function call a value
5103 denoting the number of elements to copy (i.e., most of the time the
5104 length of a deferred length string). */
5105 ulim_copy
= (formal
== NULL
)
5106 && UNLIMITED_POLY (sym
)
5107 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
5109 /* Evaluate the arguments. */
5110 for (arg
= args
, argc
= 0; arg
!= NULL
;
5111 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
5113 bool finalized
= false;
5116 fsym
= formal
? formal
->sym
: NULL
;
5117 parm_kind
= MISSING
;
5119 /* If the procedure requires an explicit interface, the actual
5120 argument is passed according to the corresponding formal
5121 argument. If the corresponding formal argument is a POINTER,
5122 ALLOCATABLE or assumed shape, we do not use g77's calling
5123 convention, and pass the address of the array descriptor
5124 instead. Otherwise we use g77's calling convention, in other words
5125 pass the array data pointer without descriptor. */
5126 bool nodesc_arg
= fsym
!= NULL
5127 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5129 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
5130 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5132 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
5134 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
5136 /* Class array expressions are sometimes coming completely unadorned
5137 with either arrayspec or _data component. Correct that here.
5138 OOP-TODO: Move this to the frontend. */
5139 if (e
&& e
->expr_type
== EXPR_VARIABLE
5141 && e
->ts
.type
== BT_CLASS
5142 && (CLASS_DATA (e
)->attr
.codimension
5143 || CLASS_DATA (e
)->attr
.dimension
))
5145 gfc_typespec temp_ts
= e
->ts
;
5146 gfc_add_class_array_ref (e
);
5152 if (se
->ignore_optional
)
5154 /* Some intrinsics have already been resolved to the correct
5158 else if (arg
->label
)
5160 has_alternate_specifier
= 1;
5165 gfc_init_se (&parmse
, NULL
);
5167 /* For scalar arguments with VALUE attribute which are passed by
5168 value, pass "0" and a hidden argument gives the optional
5170 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
5171 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
5172 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
5174 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
5176 vec_safe_push (optionalargs
, boolean_false_node
);
5180 /* Pass a NULL pointer for an absent arg. */
5181 parmse
.expr
= null_pointer_node
;
5182 if (arg
->missing_arg_type
== BT_CHARACTER
)
5183 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
5188 else if (arg
->expr
->expr_type
== EXPR_NULL
5189 && fsym
&& !fsym
->attr
.pointer
5190 && (fsym
->ts
.type
!= BT_CLASS
5191 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
5193 /* Pass a NULL pointer to denote an absent arg. */
5194 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
5195 && (fsym
->ts
.type
!= BT_CLASS
5196 || !CLASS_DATA (fsym
)->attr
.allocatable
));
5197 gfc_init_se (&parmse
, NULL
);
5198 parmse
.expr
= null_pointer_node
;
5199 if (arg
->missing_arg_type
== BT_CHARACTER
)
5200 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
5202 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
5203 && e
->ts
.type
== BT_DERIVED
)
5205 /* The derived type needs to be converted to a temporary
5207 gfc_init_se (&parmse
, se
);
5208 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
5210 && e
->expr_type
== EXPR_VARIABLE
5211 && e
->symtree
->n
.sym
->attr
.optional
,
5212 CLASS_DATA (fsym
)->attr
.class_pointer
5213 || CLASS_DATA (fsym
)->attr
.allocatable
);
5215 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
5217 /* The intrinsic type needs to be converted to a temporary
5218 CLASS object for the unlimited polymorphic formal. */
5219 gfc_init_se (&parmse
, se
);
5220 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
5222 else if (se
->ss
&& se
->ss
->info
->useflags
)
5228 /* An elemental function inside a scalarized loop. */
5229 gfc_init_se (&parmse
, se
);
5230 parm_kind
= ELEMENTAL
;
5232 /* When no fsym is present, ulim_copy is set and this is a third or
5233 fourth argument, use call-by-value instead of by reference to
5234 hand the length properties to the copy routine (i.e., most of the
5235 time this will be a call to a __copy_character_* routine where the
5236 third and fourth arguments are the lengths of a deferred length
5238 if ((fsym
&& fsym
->attr
.value
)
5239 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5240 gfc_conv_expr (&parmse
, e
);
5242 gfc_conv_expr_reference (&parmse
, e
);
5244 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5245 && e
->expr_type
== EXPR_FUNCTION
)
5246 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5249 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5250 && gfc_is_class_container_ref (e
))
5252 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5254 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5255 && e
->symtree
->n
.sym
->attr
.optional
)
5257 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5258 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5259 TREE_TYPE (parmse
.expr
),
5261 fold_convert (TREE_TYPE (parmse
.expr
),
5262 null_pointer_node
));
5266 /* If we are passing an absent array as optional dummy to an
5267 elemental procedure, make sure that we pass NULL when the data
5268 pointer is NULL. We need this extra conditional because of
5269 scalarization which passes arrays elements to the procedure,
5270 ignoring the fact that the array can be absent/unallocated/... */
5271 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5273 tree descriptor_data
;
5275 descriptor_data
= ss
->info
->data
.array
.data
;
5276 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5278 fold_convert (TREE_TYPE (descriptor_data
),
5279 null_pointer_node
));
5281 = fold_build3_loc (input_location
, COND_EXPR
,
5282 TREE_TYPE (parmse
.expr
),
5283 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5284 fold_convert (TREE_TYPE (parmse
.expr
),
5289 /* The scalarizer does not repackage the reference to a class
5290 array - instead it returns a pointer to the data element. */
5291 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5292 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5293 fsym
->attr
.intent
!= INTENT_IN
5294 && (CLASS_DATA (fsym
)->attr
.class_pointer
5295 || CLASS_DATA (fsym
)->attr
.allocatable
),
5297 && e
->expr_type
== EXPR_VARIABLE
5298 && e
->symtree
->n
.sym
->attr
.optional
,
5299 CLASS_DATA (fsym
)->attr
.class_pointer
5300 || CLASS_DATA (fsym
)->attr
.allocatable
);
5307 gfc_init_se (&parmse
, NULL
);
5309 /* Check whether the expression is a scalar or not; we cannot use
5310 e->rank as it can be nonzero for functions arguments. */
5311 argss
= gfc_walk_expr (e
);
5312 scalar
= argss
== gfc_ss_terminator
;
5314 gfc_free_ss_chain (argss
);
5316 /* Special handling for passing scalar polymorphic coarrays;
5317 otherwise one passes "class->_data.data" instead of "&class". */
5318 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5319 && fsym
&& fsym
->ts
.type
== BT_CLASS
5320 && CLASS_DATA (fsym
)->attr
.codimension
5321 && !CLASS_DATA (fsym
)->attr
.dimension
)
5323 gfc_add_class_array_ref (e
);
5324 parmse
.want_coarray
= 1;
5328 /* A scalar or transformational function. */
5331 if (e
->expr_type
== EXPR_VARIABLE
5332 && e
->symtree
->n
.sym
->attr
.cray_pointee
5333 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5335 /* The Cray pointer needs to be converted to a pointer to
5336 a type given by the expression. */
5337 gfc_conv_expr (&parmse
, e
);
5338 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5339 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5340 parmse
.expr
= convert (type
, tmp
);
5343 else if (sym
->attr
.is_bind_c
&& e
5344 && fsym
&& fsym
->attr
.dimension
5345 && (fsym
->as
->type
== AS_ASSUMED_RANK
5346 || fsym
->as
->type
== AS_ASSUMED_SHAPE
))
5347 /* Implement F2018, C.12.6.1: paragraph (2). */
5348 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5350 else if (fsym
&& fsym
->attr
.value
)
5352 if (fsym
->ts
.type
== BT_CHARACTER
5353 && fsym
->ts
.is_c_interop
5354 && fsym
->ns
->proc_name
!= NULL
5355 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5358 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5359 if (parmse
.expr
== NULL
)
5360 gfc_conv_expr (&parmse
, e
);
5364 gfc_conv_expr (&parmse
, e
);
5365 if (fsym
->attr
.optional
5366 && fsym
->ts
.type
!= BT_CLASS
5367 && fsym
->ts
.type
!= BT_DERIVED
)
5369 if (e
->expr_type
!= EXPR_VARIABLE
5370 || !e
->symtree
->n
.sym
->attr
.optional
5372 vec_safe_push (optionalargs
, boolean_true_node
);
5375 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5376 if (!e
->symtree
->n
.sym
->attr
.value
)
5378 = fold_build3_loc (input_location
, COND_EXPR
,
5379 TREE_TYPE (parmse
.expr
),
5381 fold_convert (TREE_TYPE (parmse
.expr
),
5382 integer_zero_node
));
5384 vec_safe_push (optionalargs
, tmp
);
5390 else if (arg
->name
&& arg
->name
[0] == '%')
5391 /* Argument list functions %VAL, %LOC and %REF are signalled
5392 through arg->name. */
5393 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5394 else if ((e
->expr_type
== EXPR_FUNCTION
)
5395 && ((e
->value
.function
.esym
5396 && e
->value
.function
.esym
->result
->attr
.pointer
)
5397 || (!e
->value
.function
.esym
5398 && e
->symtree
->n
.sym
->attr
.pointer
))
5399 && fsym
&& fsym
->attr
.target
)
5401 gfc_conv_expr (&parmse
, e
);
5402 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5405 else if (e
->expr_type
== EXPR_FUNCTION
5406 && e
->symtree
->n
.sym
->result
5407 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5408 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5410 /* Functions returning procedure pointers. */
5411 gfc_conv_expr (&parmse
, e
);
5412 if (fsym
&& fsym
->attr
.proc_pointer
)
5413 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5418 if (e
->ts
.type
== BT_CLASS
&& fsym
5419 && fsym
->ts
.type
== BT_CLASS
5420 && (!CLASS_DATA (fsym
)->as
5421 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5422 && CLASS_DATA (e
)->attr
.codimension
)
5424 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5425 gcc_assert (!CLASS_DATA (fsym
)->as
);
5426 gfc_add_class_array_ref (e
);
5427 parmse
.want_coarray
= 1;
5428 gfc_conv_expr_reference (&parmse
, e
);
5429 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5431 && e
->expr_type
== EXPR_VARIABLE
);
5433 else if (e
->ts
.type
== BT_CLASS
&& fsym
5434 && fsym
->ts
.type
== BT_CLASS
5435 && !CLASS_DATA (fsym
)->as
5436 && !CLASS_DATA (e
)->as
5437 && strcmp (fsym
->ts
.u
.derived
->name
,
5438 e
->ts
.u
.derived
->name
))
5440 type
= gfc_typenode_for_spec (&fsym
->ts
);
5441 var
= gfc_create_var (type
, fsym
->name
);
5442 gfc_conv_expr (&parmse
, e
);
5443 if (fsym
->attr
.optional
5444 && e
->expr_type
== EXPR_VARIABLE
5445 && e
->symtree
->n
.sym
->attr
.optional
)
5449 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5450 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5451 logical_type_node
, tmp
,
5452 fold_convert (TREE_TYPE (tmp
),
5453 null_pointer_node
));
5454 gfc_start_block (&block
);
5455 gfc_add_modify (&block
, var
,
5456 fold_build1_loc (input_location
,
5458 type
, parmse
.expr
));
5459 gfc_add_expr_to_block (&parmse
.pre
,
5460 fold_build3_loc (input_location
,
5461 COND_EXPR
, void_type_node
,
5462 cond
, gfc_finish_block (&block
),
5463 build_empty_stmt (input_location
)));
5464 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5465 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5466 TREE_TYPE (parmse
.expr
),
5468 fold_convert (TREE_TYPE (parmse
.expr
),
5469 null_pointer_node
));
5473 /* Since the internal representation of unlimited
5474 polymorphic expressions includes an extra field
5475 that other class objects do not, a cast to the
5476 formal type does not work. */
5477 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5481 /* Set the _data field. */
5482 tmp
= gfc_class_data_get (var
);
5483 efield
= fold_convert (TREE_TYPE (tmp
),
5484 gfc_class_data_get (parmse
.expr
));
5485 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5487 /* Set the _vptr field. */
5488 tmp
= gfc_class_vptr_get (var
);
5489 efield
= fold_convert (TREE_TYPE (tmp
),
5490 gfc_class_vptr_get (parmse
.expr
));
5491 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5493 /* Set the _len field. */
5494 tmp
= gfc_class_len_get (var
);
5495 gfc_add_modify (&parmse
.pre
, tmp
,
5496 build_int_cst (TREE_TYPE (tmp
), 0));
5500 tmp
= fold_build1_loc (input_location
,
5503 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5506 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5512 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5513 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5514 && !e
->symtree
->n
.sym
->attr
.dimension
5515 && !e
->symtree
->n
.sym
->attr
.pointer
5517 && !e
->symtree
->n
.sym
->attr
.dummy
5518 /* FIXME - PR 87395 and PR 41453 */
5519 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5520 && !e
->symtree
->n
.sym
->attr
.associate_var
5521 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5522 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5524 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5526 /* Catch base objects that are not variables. */
5527 if (e
->ts
.type
== BT_CLASS
5528 && e
->expr_type
!= EXPR_VARIABLE
5529 && expr
&& e
== expr
->base_expr
)
5530 base_object
= build_fold_indirect_ref_loc (input_location
,
5533 /* A class array element needs converting back to be a
5534 class object, if the formal argument is a class object. */
5535 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5536 && e
->ts
.type
== BT_CLASS
5537 && ((CLASS_DATA (fsym
)->as
5538 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5539 || CLASS_DATA (e
)->attr
.dimension
))
5540 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5541 fsym
->attr
.intent
!= INTENT_IN
5542 && (CLASS_DATA (fsym
)->attr
.class_pointer
5543 || CLASS_DATA (fsym
)->attr
.allocatable
),
5545 && e
->expr_type
== EXPR_VARIABLE
5546 && e
->symtree
->n
.sym
->attr
.optional
,
5547 CLASS_DATA (fsym
)->attr
.class_pointer
5548 || CLASS_DATA (fsym
)->attr
.allocatable
);
5550 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5551 allocated on entry, it must be deallocated. */
5552 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5553 && (fsym
->attr
.allocatable
5554 || (fsym
->ts
.type
== BT_CLASS
5555 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5560 gfc_init_block (&block
);
5562 if (e
->ts
.type
== BT_CLASS
)
5563 ptr
= gfc_class_data_get (ptr
);
5565 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5568 gfc_add_expr_to_block (&block
, tmp
);
5569 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5570 void_type_node
, ptr
,
5572 gfc_add_expr_to_block (&block
, tmp
);
5574 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5576 gfc_add_modify (&block
, ptr
,
5577 fold_convert (TREE_TYPE (ptr
),
5578 null_pointer_node
));
5579 gfc_add_expr_to_block (&block
, tmp
);
5581 else if (fsym
->ts
.type
== BT_CLASS
)
5584 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5585 tmp
= gfc_get_symbol_decl (vtab
);
5586 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5587 ptr
= gfc_class_vptr_get (parmse
.expr
);
5588 gfc_add_modify (&block
, ptr
,
5589 fold_convert (TREE_TYPE (ptr
), tmp
));
5590 gfc_add_expr_to_block (&block
, tmp
);
5593 if (fsym
->attr
.optional
5594 && e
->expr_type
== EXPR_VARIABLE
5595 && e
->symtree
->n
.sym
->attr
.optional
)
5597 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5599 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5600 gfc_finish_block (&block
),
5601 build_empty_stmt (input_location
));
5604 tmp
= gfc_finish_block (&block
);
5606 gfc_add_expr_to_block (&se
->pre
, tmp
);
5609 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5610 || fsym
->ts
.type
== BT_ASSUMED
)
5611 && e
->ts
.type
== BT_CLASS
5612 && !CLASS_DATA (e
)->attr
.dimension
5613 && !CLASS_DATA (e
)->attr
.codimension
)
5615 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5616 /* The result is a class temporary, whose _data component
5617 must be freed to avoid a memory leak. */
5618 if (e
->expr_type
== EXPR_FUNCTION
5619 && CLASS_DATA (e
)->attr
.allocatable
)
5625 /* Borrow the function symbol to make a call to
5626 gfc_add_finalizer_call and then restore it. */
5627 tmp
= e
->symtree
->n
.sym
->backend_decl
;
5628 e
->symtree
->n
.sym
->backend_decl
5629 = TREE_OPERAND (parmse
.expr
, 0);
5630 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5631 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
5632 finalized
= gfc_add_finalizer_call (&parmse
.post
,
5634 gfc_free_expr (var
);
5635 e
->symtree
->n
.sym
->backend_decl
= tmp
;
5636 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5638 /* Then free the class _data. */
5639 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
5640 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5643 tmp
= build3_v (COND_EXPR
, tmp
,
5644 gfc_call_free (parmse
.expr
),
5645 build_empty_stmt (input_location
));
5646 gfc_add_expr_to_block (&parmse
.post
, tmp
);
5647 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
5651 /* Wrap scalar variable in a descriptor. We need to convert
5652 the address of a pointer back to the pointer itself before,
5653 we can assign it to the data field. */
5655 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5656 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5659 if (TREE_CODE (tmp
) == ADDR_EXPR
)
5660 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5661 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5663 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5666 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5667 && ((fsym
->attr
.pointer
5668 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5669 || (fsym
->attr
.proc_pointer
5670 && !(e
->expr_type
== EXPR_VARIABLE
5671 && e
->symtree
->n
.sym
->attr
.dummy
))
5672 || (fsym
->attr
.proc_pointer
5673 && e
->expr_type
== EXPR_VARIABLE
5674 && gfc_is_proc_ptr_comp (e
))
5675 || (fsym
->attr
.allocatable
5676 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5678 /* Scalar pointer dummy args require an extra level of
5679 indirection. The null pointer already contains
5680 this level of indirection. */
5681 parm_kind
= SCALAR_POINTER
;
5682 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5686 else if (e
->ts
.type
== BT_CLASS
5687 && fsym
&& fsym
->ts
.type
== BT_CLASS
5688 && (CLASS_DATA (fsym
)->attr
.dimension
5689 || CLASS_DATA (fsym
)->attr
.codimension
))
5691 /* Pass a class array. */
5692 parmse
.use_offset
= 1;
5693 gfc_conv_expr_descriptor (&parmse
, e
);
5695 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5696 allocated on entry, it must be deallocated. */
5697 if (fsym
->attr
.intent
== INTENT_OUT
5698 && CLASS_DATA (fsym
)->attr
.allocatable
)
5703 gfc_init_block (&block
);
5705 ptr
= gfc_class_data_get (ptr
);
5707 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5708 NULL_TREE
, NULL_TREE
,
5710 GFC_CAF_COARRAY_NOCOARRAY
);
5711 gfc_add_expr_to_block (&block
, tmp
);
5712 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5713 void_type_node
, ptr
,
5715 gfc_add_expr_to_block (&block
, tmp
);
5716 gfc_reset_vptr (&block
, e
);
5718 if (fsym
->attr
.optional
5719 && e
->expr_type
== EXPR_VARIABLE
5721 || (e
->ref
->type
== REF_ARRAY
5722 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5723 && e
->symtree
->n
.sym
->attr
.optional
)
5725 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5727 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5728 gfc_finish_block (&block
),
5729 build_empty_stmt (input_location
));
5732 tmp
= gfc_finish_block (&block
);
5734 gfc_add_expr_to_block (&se
->pre
, tmp
);
5737 /* The conversion does not repackage the reference to a class
5738 array - _data descriptor. */
5739 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5740 fsym
->attr
.intent
!= INTENT_IN
5741 && (CLASS_DATA (fsym
)->attr
.class_pointer
5742 || CLASS_DATA (fsym
)->attr
.allocatable
),
5744 && e
->expr_type
== EXPR_VARIABLE
5745 && e
->symtree
->n
.sym
->attr
.optional
,
5746 CLASS_DATA (fsym
)->attr
.class_pointer
5747 || CLASS_DATA (fsym
)->attr
.allocatable
);
5751 /* If the argument is a function call that may not create
5752 a temporary for the result, we have to check that we
5753 can do it, i.e. that there is no alias between this
5754 argument and another one. */
5755 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5761 intent
= fsym
->attr
.intent
;
5763 intent
= INTENT_UNKNOWN
;
5765 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5767 parmse
.force_tmp
= 1;
5769 iarg
= e
->value
.function
.actual
->expr
;
5771 /* Temporary needed if aliasing due to host association. */
5772 if (sym
->attr
.contained
5774 && !sym
->attr
.implicit_pure
5775 && !sym
->attr
.use_assoc
5776 && iarg
->expr_type
== EXPR_VARIABLE
5777 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5778 parmse
.force_tmp
= 1;
5780 /* Ditto within module. */
5781 if (sym
->attr
.use_assoc
5783 && !sym
->attr
.implicit_pure
5784 && iarg
->expr_type
== EXPR_VARIABLE
5785 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5786 parmse
.force_tmp
= 1;
5789 if (sym
->attr
.is_bind_c
&& e
5790 && fsym
&& fsym
->attr
.dimension
5791 && (fsym
->as
->type
== AS_ASSUMED_RANK
5792 || fsym
->as
->type
== AS_ASSUMED_SHAPE
))
5793 /* Implement F2018, C.12.6.1: paragraph (2). */
5794 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
5796 else if (e
->expr_type
== EXPR_VARIABLE
5797 && is_subref_array (e
)
5798 && !(fsym
&& fsym
->attr
.pointer
))
5799 /* The actual argument is a component reference to an
5800 array of derived types. In this case, the argument
5801 is converted to a temporary, which is passed and then
5802 written back after the procedure call. */
5803 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5804 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5805 fsym
&& fsym
->attr
.pointer
);
5807 else if (gfc_is_class_array_ref (e
, NULL
)
5808 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5809 /* The actual argument is a component reference to an
5810 array of derived types. In this case, the argument
5811 is converted to a temporary, which is passed and then
5812 written back after the procedure call.
5813 OOP-TODO: Insert code so that if the dynamic type is
5814 the same as the declared type, copy-in/copy-out does
5816 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5817 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5818 fsym
&& fsym
->attr
.pointer
);
5820 else if (gfc_is_class_array_function (e
)
5821 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5822 /* See previous comment. For function actual argument,
5823 the write out is not needed so the intent is set as
5826 e
->must_finalize
= 1;
5827 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5829 fsym
&& fsym
->attr
.pointer
);
5831 else if (fsym
&& fsym
->attr
.contiguous
5832 && !gfc_is_simply_contiguous (e
, false, true))
5834 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5835 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5836 fsym
&& fsym
->attr
.pointer
);
5839 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5842 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5843 allocated on entry, it must be deallocated. */
5844 if (fsym
&& fsym
->attr
.allocatable
5845 && fsym
->attr
.intent
== INTENT_OUT
)
5847 if (fsym
->ts
.type
== BT_DERIVED
5848 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5850 // deallocate the components first
5851 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5852 parmse
.expr
, e
->rank
);
5853 if (tmp
!= NULL_TREE
)
5854 gfc_add_expr_to_block (&se
->pre
, tmp
);
5857 tmp
= build_fold_indirect_ref_loc (input_location
,
5859 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5860 tmp
= gfc_conv_descriptor_data_get (tmp
);
5861 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5862 NULL_TREE
, NULL_TREE
, true,
5864 GFC_CAF_COARRAY_NOCOARRAY
);
5865 if (fsym
->attr
.optional
5866 && e
->expr_type
== EXPR_VARIABLE
5867 && e
->symtree
->n
.sym
->attr
.optional
)
5868 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5870 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5871 tmp
, build_empty_stmt (input_location
));
5872 gfc_add_expr_to_block (&se
->pre
, tmp
);
5877 /* The case with fsym->attr.optional is that of a user subroutine
5878 with an interface indicating an optional argument. When we call
5879 an intrinsic subroutine, however, fsym is NULL, but we might still
5880 have an optional argument, so we proceed to the substitution
5882 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5884 /* If an optional argument is itself an optional dummy argument,
5885 check its presence and substitute a null if absent. This is
5886 only needed when passing an array to an elemental procedure
5887 as then array elements are accessed - or no NULL pointer is
5888 allowed and a "1" or "0" should be passed if not present.
5889 When passing a non-array-descriptor full array to a
5890 non-array-descriptor dummy, no check is needed. For
5891 array-descriptor actual to array-descriptor dummy, see
5892 PR 41911 for why a check has to be inserted.
5893 fsym == NULL is checked as intrinsics required the descriptor
5894 but do not always set fsym.
5895 Also, it is necessary to pass a NULL pointer to library routines
5896 which usually ignore optional arguments, so they can handle
5897 these themselves. */
5898 if (e
->expr_type
== EXPR_VARIABLE
5899 && e
->symtree
->n
.sym
->attr
.optional
5900 && (((e
->rank
!= 0 && elemental_proc
)
5901 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5905 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5906 || fsym
->as
->type
== AS_ASSUMED_RANK
5907 || fsym
->as
->type
== AS_DEFERRED
)))))
5908 || se
->ignore_optional
))
5909 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5910 e
->representation
.length
);
5915 /* Obtain the character length of an assumed character length
5916 length procedure from the typespec. */
5917 if (fsym
->ts
.type
== BT_CHARACTER
5918 && parmse
.string_length
== NULL_TREE
5919 && e
->ts
.type
== BT_PROCEDURE
5920 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5921 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5922 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5924 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5925 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5929 if (fsym
&& need_interface_mapping
&& e
)
5930 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5932 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5933 gfc_add_block_to_block (&post
, &parmse
.post
);
5935 /* Allocated allocatable components of derived types must be
5936 deallocated for non-variable scalars, array arguments to elemental
5937 procedures, and array arguments with descriptor to non-elemental
5938 procedures. As bounds information for descriptorless arrays is no
5939 longer available here, they are dealt with in trans-array.c
5940 (gfc_conv_array_parameter). */
5941 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5942 && e
->ts
.u
.derived
->attr
.alloc_comp
5943 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5944 && !expr_may_alias_variables (e
, elemental_proc
))
5947 /* It is known the e returns a structure type with at least one
5948 allocatable component. When e is a function, ensure that the
5949 function is called once only by using a temporary variable. */
5950 if (!DECL_P (parmse
.expr
))
5951 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5952 parmse
.expr
, &se
->pre
);
5954 if (fsym
&& fsym
->attr
.value
)
5957 tmp
= build_fold_indirect_ref_loc (input_location
,
5960 parm_rank
= e
->rank
;
5968 case (SCALAR_POINTER
):
5969 tmp
= build_fold_indirect_ref_loc (input_location
,
5974 if (e
->expr_type
== EXPR_OP
5975 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5976 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5979 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5980 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5982 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5985 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5987 /* The derived type is passed to gfc_deallocate_alloc_comp.
5988 Therefore, class actuals can handled correctly but derived
5989 types passed to class formals need the _data component. */
5990 tmp
= gfc_class_data_get (tmp
);
5991 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5992 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5995 if (!finalized
&& !e
->must_finalize
)
5997 if ((e
->ts
.type
== BT_CLASS
5998 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
5999 || e
->ts
.type
== BT_DERIVED
)
6000 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
6002 else if (e
->ts
.type
== BT_CLASS
)
6003 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
6005 gfc_prepend_expr_to_block (&post
, tmp
);
6009 /* Add argument checking of passing an unallocated/NULL actual to
6010 a nonallocatable/nonpointer dummy. */
6012 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
6014 symbol_attribute attr
;
6018 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
6019 attr
= gfc_expr_attr (e
);
6021 goto end_pointer_check
;
6023 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6024 allocatable to an optional dummy, cf. 12.5.2.12. */
6025 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
6026 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
6027 goto end_pointer_check
;
6031 /* If the actual argument is an optional pointer/allocatable and
6032 the formal argument takes an nonpointer optional value,
6033 it is invalid to pass a non-present argument on, even
6034 though there is no technical reason for this in gfortran.
6035 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6036 tree present
, null_ptr
, type
;
6038 if (attr
.allocatable
6039 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6040 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6041 "allocated or not present",
6042 e
->symtree
->n
.sym
->name
);
6043 else if (attr
.pointer
6044 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6045 msg
= xasprintf ("Pointer actual argument '%s' is not "
6046 "associated or not present",
6047 e
->symtree
->n
.sym
->name
);
6048 else if (attr
.proc_pointer
6049 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6050 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6051 "associated or not present",
6052 e
->symtree
->n
.sym
->name
);
6054 goto end_pointer_check
;
6056 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6057 type
= TREE_TYPE (present
);
6058 present
= fold_build2_loc (input_location
, EQ_EXPR
,
6059 logical_type_node
, present
,
6061 null_pointer_node
));
6062 type
= TREE_TYPE (parmse
.expr
);
6063 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
6064 logical_type_node
, parmse
.expr
,
6066 null_pointer_node
));
6067 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
6068 logical_type_node
, present
, null_ptr
);
6072 if (attr
.allocatable
6073 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
6074 msg
= xasprintf ("Allocatable actual argument '%s' is not "
6075 "allocated", e
->symtree
->n
.sym
->name
);
6076 else if (attr
.pointer
6077 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
6078 msg
= xasprintf ("Pointer actual argument '%s' is not "
6079 "associated", e
->symtree
->n
.sym
->name
);
6080 else if (attr
.proc_pointer
6081 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
6082 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
6083 "associated", e
->symtree
->n
.sym
->name
);
6085 goto end_pointer_check
;
6089 /* If the argument is passed by value, we need to strip the
6091 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
6092 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6094 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6095 logical_type_node
, tmp
,
6096 fold_convert (TREE_TYPE (tmp
),
6097 null_pointer_node
));
6100 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
6106 /* Deferred length dummies pass the character length by reference
6107 so that the value can be returned. */
6108 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
6110 if (INDIRECT_REF_P (parmse
.string_length
))
6111 /* In chains of functions/procedure calls the string_length already
6112 is a pointer to the variable holding the length. Therefore
6113 remove the deref on call. */
6114 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
6117 tmp
= parmse
.string_length
;
6118 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
6119 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
6120 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6124 /* Character strings are passed as two parameters, a length and a
6125 pointer - except for Bind(c) which only passes the pointer.
6126 An unlimited polymorphic formal argument likewise does not
6128 if (parmse
.string_length
!= NULL_TREE
6129 && !sym
->attr
.is_bind_c
6130 && !(fsym
&& UNLIMITED_POLY (fsym
)))
6131 vec_safe_push (stringargs
, parmse
.string_length
);
6133 /* When calling __copy for character expressions to unlimited
6134 polymorphic entities, the dst argument needs a string length. */
6135 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
6136 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
6137 && arg
->next
&& arg
->next
->expr
6138 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
6139 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
6140 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
6141 vec_safe_push (stringargs
, parmse
.string_length
);
6143 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6144 pass the token and the offset as additional arguments. */
6145 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
6146 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6147 && !fsym
->attr
.allocatable
)
6148 || (fsym
->ts
.type
== BT_CLASS
6149 && CLASS_DATA (fsym
)->attr
.codimension
6150 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6152 /* Token and offset. */
6153 vec_safe_push (stringargs
, null_pointer_node
);
6154 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
6155 gcc_assert (fsym
->attr
.optional
);
6157 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
6158 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
6159 && !fsym
->attr
.allocatable
)
6160 || (fsym
->ts
.type
== BT_CLASS
6161 && CLASS_DATA (fsym
)->attr
.codimension
6162 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
6164 tree caf_decl
, caf_type
;
6167 caf_decl
= gfc_get_tree_for_caf_expr (e
);
6168 caf_type
= TREE_TYPE (caf_decl
);
6170 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6171 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
6172 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
6173 tmp
= gfc_conv_descriptor_token (caf_decl
);
6174 else if (DECL_LANG_SPECIFIC (caf_decl
)
6175 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
6176 tmp
= GFC_DECL_TOKEN (caf_decl
);
6179 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
6180 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
6181 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
6184 vec_safe_push (stringargs
, tmp
);
6186 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
6187 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
6188 offset
= build_int_cst (gfc_array_index_type
, 0);
6189 else if (DECL_LANG_SPECIFIC (caf_decl
)
6190 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
6191 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
6192 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
6193 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
6195 offset
= build_int_cst (gfc_array_index_type
, 0);
6197 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
6198 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
6201 gcc_assert (POINTER_TYPE_P (caf_type
));
6205 tmp2
= fsym
->ts
.type
== BT_CLASS
6206 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
6207 if ((fsym
->ts
.type
!= BT_CLASS
6208 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6209 || fsym
->as
->type
== AS_ASSUMED_RANK
))
6210 || (fsym
->ts
.type
== BT_CLASS
6211 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
6212 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
6214 if (fsym
->ts
.type
== BT_CLASS
)
6215 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6218 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6219 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
6221 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
6222 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6224 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
6225 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
6228 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
6231 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6232 gfc_array_index_type
,
6233 fold_convert (gfc_array_index_type
, tmp2
),
6234 fold_convert (gfc_array_index_type
, tmp
));
6235 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
6236 gfc_array_index_type
, offset
, tmp
);
6238 vec_safe_push (stringargs
, offset
);
6241 vec_safe_push (arglist
, parmse
.expr
);
6243 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
6247 else if (sym
->ts
.type
== BT_CLASS
)
6248 ts
= CLASS_DATA (sym
)->ts
;
6252 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
6253 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6254 else if (ts
.type
== BT_CHARACTER
)
6256 if (ts
.u
.cl
->length
== NULL
)
6258 /* Assumed character length results are not allowed by C418 of the 2003
6259 standard and are trapped in resolve.c; except in the case of SPREAD
6260 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6261 we take the character length of the first argument for the result.
6262 For dummies, we have to look through the formal argument list for
6263 this function and use the character length found there.*/
6265 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6266 else if (!sym
->attr
.dummy
)
6267 cl
.backend_decl
= (*stringargs
)[0];
6270 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6271 for (; formal
; formal
= formal
->next
)
6272 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6273 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6275 len
= cl
.backend_decl
;
6281 /* Calculate the length of the returned string. */
6282 gfc_init_se (&parmse
, NULL
);
6283 if (need_interface_mapping
)
6284 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6286 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6287 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6288 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6290 /* TODO: It would be better to have the charlens as
6291 gfc_charlen_type_node already when the interface is
6292 created instead of converting it here (see PR 84615). */
6293 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6294 gfc_charlen_type_node
,
6295 fold_convert (gfc_charlen_type_node
, tmp
),
6296 build_zero_cst (gfc_charlen_type_node
));
6297 cl
.backend_decl
= tmp
;
6300 /* Set up a charlen structure for it. */
6305 len
= cl
.backend_decl
;
6308 byref
= (comp
&& (comp
->attr
.dimension
6309 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6310 || (!comp
&& gfc_return_by_reference (sym
));
6313 if (se
->direct_byref
)
6315 /* Sometimes, too much indirection can be applied; e.g. for
6316 function_result = array_valued_recursive_function. */
6317 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6318 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6319 && GFC_DESCRIPTOR_TYPE_P
6320 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6321 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6324 /* If the lhs of an assignment x = f(..) is allocatable and
6325 f2003 is allowed, we must do the automatic reallocation.
6326 TODO - deal with intrinsics, without using a temporary. */
6327 if (flag_realloc_lhs
6328 && se
->ss
&& se
->ss
->loop_chain
6329 && se
->ss
->loop_chain
->is_alloc_lhs
6330 && !expr
->value
.function
.isym
6331 && sym
->result
->as
!= NULL
)
6333 /* Evaluate the bounds of the result, if known. */
6334 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6337 /* Perform the automatic reallocation. */
6338 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6340 gfc_add_expr_to_block (&se
->pre
, tmp
);
6342 /* Pass the temporary as the first argument. */
6343 result
= info
->descriptor
;
6346 result
= build_fold_indirect_ref_loc (input_location
,
6348 vec_safe_push (retargs
, se
->expr
);
6350 else if (comp
&& comp
->attr
.dimension
)
6352 gcc_assert (se
->loop
&& info
);
6354 /* Set the type of the array. */
6355 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6356 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6358 /* Evaluate the bounds of the result, if known. */
6359 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6361 /* If the lhs of an assignment x = f(..) is allocatable and
6362 f2003 is allowed, we must not generate the function call
6363 here but should just send back the results of the mapping.
6364 This is signalled by the function ss being flagged. */
6365 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6367 gfc_free_interface_mapping (&mapping
);
6368 return has_alternate_specifier
;
6371 /* Create a temporary to store the result. In case the function
6372 returns a pointer, the temporary will be a shallow copy and
6373 mustn't be deallocated. */
6374 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6375 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6376 tmp
, NULL_TREE
, false,
6377 !comp
->attr
.pointer
, callee_alloc
,
6378 &se
->ss
->info
->expr
->where
);
6380 /* Pass the temporary as the first argument. */
6381 result
= info
->descriptor
;
6382 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6383 vec_safe_push (retargs
, tmp
);
6385 else if (!comp
&& sym
->result
->attr
.dimension
)
6387 gcc_assert (se
->loop
&& info
);
6389 /* Set the type of the array. */
6390 tmp
= gfc_typenode_for_spec (&ts
);
6391 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6393 /* Evaluate the bounds of the result, if known. */
6394 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6396 /* If the lhs of an assignment x = f(..) is allocatable and
6397 f2003 is allowed, we must not generate the function call
6398 here but should just send back the results of the mapping.
6399 This is signalled by the function ss being flagged. */
6400 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6402 gfc_free_interface_mapping (&mapping
);
6403 return has_alternate_specifier
;
6406 /* Create a temporary to store the result. In case the function
6407 returns a pointer, the temporary will be a shallow copy and
6408 mustn't be deallocated. */
6409 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6410 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6411 tmp
, NULL_TREE
, false,
6412 !sym
->attr
.pointer
, callee_alloc
,
6413 &se
->ss
->info
->expr
->where
);
6415 /* Pass the temporary as the first argument. */
6416 result
= info
->descriptor
;
6417 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6418 vec_safe_push (retargs
, tmp
);
6420 else if (ts
.type
== BT_CHARACTER
)
6422 /* Pass the string length. */
6423 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6424 type
= build_pointer_type (type
);
6426 /* Emit a DECL_EXPR for the VLA type. */
6427 tmp
= TREE_TYPE (type
);
6429 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6431 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6432 DECL_ARTIFICIAL (tmp
) = 1;
6433 DECL_IGNORED_P (tmp
) = 1;
6434 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6435 TREE_TYPE (tmp
), tmp
);
6436 gfc_add_expr_to_block (&se
->pre
, tmp
);
6439 /* Return an address to a char[0:len-1]* temporary for
6440 character pointers. */
6441 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6442 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6444 var
= gfc_create_var (type
, "pstr");
6446 if ((!comp
&& sym
->attr
.allocatable
)
6447 || (comp
&& comp
->attr
.allocatable
))
6449 gfc_add_modify (&se
->pre
, var
,
6450 fold_convert (TREE_TYPE (var
),
6451 null_pointer_node
));
6452 tmp
= gfc_call_free (var
);
6453 gfc_add_expr_to_block (&se
->post
, tmp
);
6456 /* Provide an address expression for the function arguments. */
6457 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6460 var
= gfc_conv_string_tmp (se
, type
, len
);
6462 vec_safe_push (retargs
, var
);
6466 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6468 type
= gfc_get_complex_type (ts
.kind
);
6469 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6470 vec_safe_push (retargs
, var
);
6473 /* Add the string length to the argument list. */
6474 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6478 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6479 TREE_STATIC (tmp
) = 1;
6480 gfc_add_modify (&se
->pre
, tmp
,
6481 build_int_cst (TREE_TYPE (tmp
), 0));
6482 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6483 vec_safe_push (retargs
, tmp
);
6485 else if (ts
.type
== BT_CHARACTER
)
6486 vec_safe_push (retargs
, len
);
6488 gfc_free_interface_mapping (&mapping
);
6490 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6491 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6492 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6493 vec_safe_reserve (retargs
, arglen
);
6495 /* Add the return arguments. */
6496 vec_safe_splice (retargs
, arglist
);
6498 /* Add the hidden present status for optional+value to the arguments. */
6499 vec_safe_splice (retargs
, optionalargs
);
6501 /* Add the hidden string length parameters to the arguments. */
6502 vec_safe_splice (retargs
, stringargs
);
6504 /* We may want to append extra arguments here. This is used e.g. for
6505 calls to libgfortran_matmul_??, which need extra information. */
6506 vec_safe_splice (retargs
, append_args
);
6510 /* Generate the actual call. */
6511 if (base_object
== NULL_TREE
)
6512 conv_function_val (se
, sym
, expr
);
6514 conv_base_obj_fcn_val (se
, base_object
, expr
);
6516 /* If there are alternate return labels, function type should be
6517 integer. Can't modify the type in place though, since it can be shared
6518 with other functions. For dummy arguments, the typing is done to
6519 this result, even if it has to be repeated for each call. */
6520 if (has_alternate_specifier
6521 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6523 if (!sym
->attr
.dummy
)
6525 TREE_TYPE (sym
->backend_decl
)
6526 = build_function_type (integer_type_node
,
6527 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6528 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6531 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6534 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6535 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6537 /* Allocatable scalar function results must be freed and nullified
6538 after use. This necessitates the creation of a temporary to
6539 hold the result to prevent duplicate calls. */
6540 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6541 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6542 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6544 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6545 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6547 tmp
= gfc_call_free (tmp
);
6548 gfc_add_expr_to_block (&post
, tmp
);
6549 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6552 /* If we have a pointer function, but we don't want a pointer, e.g.
6555 where f is pointer valued, we have to dereference the result. */
6556 if (!se
->want_pointer
&& !byref
6557 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6558 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6559 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6561 /* f2c calling conventions require a scalar default real function to
6562 return a double precision result. Convert this back to default
6563 real. We only care about the cases that can happen in Fortran 77.
6565 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6566 && sym
->ts
.kind
== gfc_default_real_kind
6567 && !sym
->attr
.always_explicit
)
6568 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6570 /* A pure function may still have side-effects - it may modify its
6572 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6574 if (!sym
->attr
.pure
)
6575 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6580 /* Add the function call to the pre chain. There is no expression. */
6581 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6582 se
->expr
= NULL_TREE
;
6584 if (!se
->direct_byref
)
6586 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6588 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6590 /* Check the data pointer hasn't been modified. This would
6591 happen in a function returning a pointer. */
6592 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6593 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6596 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6599 se
->expr
= info
->descriptor
;
6600 /* Bundle in the string length. */
6601 se
->string_length
= len
;
6603 else if (ts
.type
== BT_CHARACTER
)
6605 /* Dereference for character pointer results. */
6606 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6607 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6608 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6612 se
->string_length
= len
;
6616 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6617 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6622 /* Associate the rhs class object's meta-data with the result, when the
6623 result is a temporary. */
6624 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6625 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6626 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6629 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6631 gfc_init_se (&parmse
, NULL
);
6632 parmse
.data_not_needed
= 1;
6633 gfc_conv_expr (&parmse
, class_expr
);
6634 if (!DECL_LANG_SPECIFIC (result
))
6635 gfc_allocate_lang_decl (result
);
6636 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6637 gfc_free_expr (class_expr
);
6638 gcc_assert (parmse
.pre
.head
== NULL_TREE
6639 && parmse
.post
.head
== NULL_TREE
);
6642 /* Follow the function call with the argument post block. */
6645 gfc_add_block_to_block (&se
->pre
, &post
);
6647 /* Transformational functions of derived types with allocatable
6648 components must have the result allocatable components copied when the
6649 argument is actually given. */
6650 arg
= expr
->value
.function
.actual
;
6651 if (result
&& arg
&& expr
->rank
6652 && expr
->value
.function
.isym
6653 && expr
->value
.function
.isym
->transformational
6655 && arg
->expr
->ts
.type
== BT_DERIVED
6656 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6659 /* Copy the allocatable components. We have to use a
6660 temporary here to prevent source allocatable components
6661 from being corrupted. */
6662 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6663 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6664 result
, tmp2
, expr
->rank
, 0);
6665 gfc_add_expr_to_block (&se
->pre
, tmp
);
6666 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6668 gfc_add_expr_to_block (&se
->pre
, tmp
);
6670 /* Finally free the temporary's data field. */
6671 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6672 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6673 NULL_TREE
, NULL_TREE
, true,
6674 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6675 gfc_add_expr_to_block (&se
->pre
, tmp
);
6680 /* For a function with a class array result, save the result as
6681 a temporary, set the info fields needed by the scalarizer and
6682 call the finalization function of the temporary. Note that the
6683 nullification of allocatable components needed by the result
6684 is done in gfc_trans_assignment_1. */
6685 if (expr
&& ((gfc_is_class_array_function (expr
)
6686 && se
->ss
&& se
->ss
->loop
)
6687 || gfc_is_alloc_class_scalar_function (expr
))
6688 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6689 && expr
->must_finalize
)
6694 if (se
->ss
&& se
->ss
->loop
)
6696 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
6697 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6698 tmp
= gfc_class_data_get (se
->expr
);
6699 info
->descriptor
= tmp
;
6700 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6701 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6702 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6704 tree dim
= gfc_rank_cst
[n
];
6705 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6706 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6711 /* TODO Eliminate the doubling of temporaries. This
6712 one is necessary to ensure no memory leakage. */
6713 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6714 tmp
= gfc_class_data_get (se
->expr
);
6715 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6716 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6719 if ((gfc_is_class_array_function (expr
)
6720 || gfc_is_alloc_class_scalar_function (expr
))
6721 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
6722 goto no_finalization
;
6724 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6725 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6728 fold_convert (TREE_TYPE (final_fndecl
),
6729 null_pointer_node
));
6730 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6732 tmp
= build_call_expr_loc (input_location
,
6734 gfc_build_addr_expr (NULL
, tmp
),
6735 gfc_class_vtab_size_get (se
->expr
),
6736 boolean_false_node
);
6737 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6738 void_type_node
, is_final
, tmp
,
6739 build_empty_stmt (input_location
));
6741 if (se
->ss
&& se
->ss
->loop
)
6743 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6744 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6747 fold_convert (TREE_TYPE (info
->data
),
6748 null_pointer_node
));
6749 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6750 void_type_node
, tmp
,
6751 gfc_call_free (info
->data
),
6752 build_empty_stmt (input_location
));
6753 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6758 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6759 classdata
= gfc_class_data_get (se
->expr
);
6760 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6763 fold_convert (TREE_TYPE (classdata
),
6764 null_pointer_node
));
6765 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6766 void_type_node
, tmp
,
6767 gfc_call_free (classdata
),
6768 build_empty_stmt (input_location
));
6769 gfc_add_expr_to_block (&se
->post
, tmp
);
6774 gfc_add_block_to_block (&se
->post
, &post
);
6777 return has_alternate_specifier
;
6781 /* Fill a character string with spaces. */
6784 fill_with_spaces (tree start
, tree type
, tree size
)
6786 stmtblock_t block
, loop
;
6787 tree i
, el
, exit_label
, cond
, tmp
;
6789 /* For a simple char type, we can call memset(). */
6790 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6791 return build_call_expr_loc (input_location
,
6792 builtin_decl_explicit (BUILT_IN_MEMSET
),
6794 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6795 lang_hooks
.to_target_charset (' ')),
6796 fold_convert (size_type_node
, size
));
6798 /* Otherwise, we use a loop:
6799 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6803 /* Initialize variables. */
6804 gfc_init_block (&block
);
6805 i
= gfc_create_var (sizetype
, "i");
6806 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6807 el
= gfc_create_var (build_pointer_type (type
), "el");
6808 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6809 exit_label
= gfc_build_label_decl (NULL_TREE
);
6810 TREE_USED (exit_label
) = 1;
6814 gfc_init_block (&loop
);
6816 /* Exit condition. */
6817 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6818 build_zero_cst (sizetype
));
6819 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6820 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6821 build_empty_stmt (input_location
));
6822 gfc_add_expr_to_block (&loop
, tmp
);
6825 gfc_add_modify (&loop
,
6826 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6827 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6829 /* Increment loop variables. */
6830 gfc_add_modify (&loop
, i
,
6831 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6832 TYPE_SIZE_UNIT (type
)));
6833 gfc_add_modify (&loop
, el
,
6834 fold_build_pointer_plus_loc (input_location
,
6835 el
, TYPE_SIZE_UNIT (type
)));
6837 /* Making the loop... actually loop! */
6838 tmp
= gfc_finish_block (&loop
);
6839 tmp
= build1_v (LOOP_EXPR
, tmp
);
6840 gfc_add_expr_to_block (&block
, tmp
);
6842 /* The exit label. */
6843 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6844 gfc_add_expr_to_block (&block
, tmp
);
6847 return gfc_finish_block (&block
);
6851 /* Generate code to copy a string. */
6854 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6855 int dkind
, tree slength
, tree src
, int skind
)
6857 tree tmp
, dlen
, slen
;
6866 stmtblock_t tempblock
;
6868 gcc_assert (dkind
== skind
);
6870 if (slength
!= NULL_TREE
)
6872 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
6873 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6877 slen
= build_one_cst (gfc_charlen_type_node
);
6881 if (dlength
!= NULL_TREE
)
6883 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
6884 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6888 dlen
= build_one_cst (gfc_charlen_type_node
);
6892 /* Assign directly if the types are compatible. */
6893 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6894 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6896 gfc_add_modify (block
, dsc
, ssc
);
6900 /* The string copy algorithm below generates code like
6904 if (srclen < destlen)
6906 memmove (dest, src, srclen);
6908 memset (&dest[srclen], ' ', destlen - srclen);
6912 // Truncate if too long.
6913 memmove (dest, src, destlen);
6918 /* Do nothing if the destination length is zero. */
6919 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6920 build_zero_cst (TREE_TYPE (dlen
)));
6922 /* For non-default character kinds, we have to multiply the string
6923 length by the base type size. */
6924 chartype
= gfc_get_char_type (dkind
);
6925 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
6927 fold_convert (TREE_TYPE (slen
),
6928 TYPE_SIZE_UNIT (chartype
)));
6929 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
6931 fold_convert (TREE_TYPE (dlen
),
6932 TYPE_SIZE_UNIT (chartype
)));
6934 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6935 dest
= fold_convert (pvoid_type_node
, dest
);
6937 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6939 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6940 src
= fold_convert (pvoid_type_node
, src
);
6942 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6944 /* Truncate string if source is too long. */
6945 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6948 /* Copy and pad with spaces. */
6949 tmp3
= build_call_expr_loc (input_location
,
6950 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6952 fold_convert (size_type_node
, slen
));
6954 /* Wstringop-overflow appears at -O3 even though this warning is not
6955 explicitly available in fortran nor can it be switched off. If the
6956 source length is a constant, its negative appears as a very large
6957 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6958 the result of the MINUS_EXPR suppresses this spurious warning. */
6959 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6960 TREE_TYPE(dlen
), dlen
, slen
);
6961 if (slength
&& TREE_CONSTANT (slength
))
6962 tmp
= gfc_evaluate_now (tmp
, block
);
6964 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6965 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6967 gfc_init_block (&tempblock
);
6968 gfc_add_expr_to_block (&tempblock
, tmp3
);
6969 gfc_add_expr_to_block (&tempblock
, tmp4
);
6970 tmp3
= gfc_finish_block (&tempblock
);
6972 /* The truncated memmove if the slen >= dlen. */
6973 tmp2
= build_call_expr_loc (input_location
,
6974 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6976 fold_convert (size_type_node
, dlen
));
6978 /* The whole copy_string function is there. */
6979 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6981 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6982 build_empty_stmt (input_location
));
6983 gfc_add_expr_to_block (block
, tmp
);
6987 /* Translate a statement function.
6988 The value of a statement function reference is obtained by evaluating the
6989 expression using the values of the actual arguments for the values of the
6990 corresponding dummy arguments. */
6993 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6997 gfc_formal_arglist
*fargs
;
6998 gfc_actual_arglist
*args
;
7001 gfc_saved_var
*saved_vars
;
7007 sym
= expr
->symtree
->n
.sym
;
7008 args
= expr
->value
.function
.actual
;
7009 gfc_init_se (&lse
, NULL
);
7010 gfc_init_se (&rse
, NULL
);
7013 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
7015 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
7016 temp_vars
= XCNEWVEC (tree
, n
);
7018 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7019 fargs
= fargs
->next
, n
++)
7021 /* Each dummy shall be specified, explicitly or implicitly, to be
7023 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
7026 if (fsym
->ts
.type
== BT_CHARACTER
)
7028 /* Copy string arguments. */
7031 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
7032 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
7034 /* Create a temporary to hold the value. */
7035 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
7036 fsym
->ts
.u
.cl
->backend_decl
7037 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
7039 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
7040 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7042 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
7044 gfc_conv_expr (&rse
, args
->expr
);
7045 gfc_conv_string_parameter (&rse
);
7046 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7047 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
7049 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
7050 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
7051 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7052 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
7056 /* For everything else, just evaluate the expression. */
7058 /* Create a temporary to hold the value. */
7059 type
= gfc_typenode_for_spec (&fsym
->ts
);
7060 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
7062 gfc_conv_expr (&lse
, args
->expr
);
7064 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
7065 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
7066 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
7072 /* Use the temporary variables in place of the real ones. */
7073 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7074 fargs
= fargs
->next
, n
++)
7075 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
7077 gfc_conv_expr (se
, sym
->value
);
7079 if (sym
->ts
.type
== BT_CHARACTER
)
7081 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
7083 /* Force the expression to the correct length. */
7084 if (!INTEGER_CST_P (se
->string_length
)
7085 || tree_int_cst_lt (se
->string_length
,
7086 sym
->ts
.u
.cl
->backend_decl
))
7088 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
7089 tmp
= gfc_create_var (type
, sym
->name
);
7090 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
7091 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
7092 sym
->ts
.kind
, se
->string_length
, se
->expr
,
7096 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
7099 /* Restore the original variables. */
7100 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
7101 fargs
= fargs
->next
, n
++)
7102 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
7108 /* Translate a function expression. */
7111 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
7115 if (expr
->value
.function
.isym
)
7117 gfc_conv_intrinsic_function (se
, expr
);
7121 /* expr.value.function.esym is the resolved (specific) function symbol for
7122 most functions. However this isn't set for dummy procedures. */
7123 sym
= expr
->value
.function
.esym
;
7125 sym
= expr
->symtree
->n
.sym
;
7127 /* The IEEE_ARITHMETIC functions are caught here. */
7128 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
7129 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
7132 /* We distinguish statement functions from general functions to improve
7133 runtime performance. */
7134 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7136 gfc_conv_statement_function (se
, expr
);
7140 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
7145 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7148 is_zero_initializer_p (gfc_expr
* expr
)
7150 if (expr
->expr_type
!= EXPR_CONSTANT
)
7153 /* We ignore constants with prescribed memory representations for now. */
7154 if (expr
->representation
.string
)
7157 switch (expr
->ts
.type
)
7160 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
7163 return mpfr_zero_p (expr
->value
.real
)
7164 && MPFR_SIGN (expr
->value
.real
) >= 0;
7167 return expr
->value
.logical
== 0;
7170 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
7171 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
7172 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
7173 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
7183 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
7188 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
7189 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
7191 gfc_conv_tmp_array_ref (se
);
7195 /* Build a static initializer. EXPR is the expression for the initial value.
7196 The other parameters describe the variable of the component being
7197 initialized. EXPR may be null. */
7200 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
7201 bool array
, bool pointer
, bool procptr
)
7205 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
7206 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
7207 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
7208 return build_constructor (type
, NULL
);
7210 if (!(expr
|| pointer
|| procptr
))
7213 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7214 (these are the only two iso_c_binding derived types that can be
7215 used as initialization expressions). If so, we need to modify
7216 the 'expr' to be that for a (void *). */
7217 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
7218 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
7220 if (TREE_CODE (type
) == ARRAY_TYPE
)
7221 return build_constructor (type
, NULL
);
7222 else if (POINTER_TYPE_P (type
))
7223 return build_int_cst (type
, 0);
7228 if (array
&& !procptr
)
7231 /* Arrays need special handling. */
7233 ctor
= gfc_build_null_descriptor (type
);
7234 /* Special case assigning an array to zero. */
7235 else if (is_zero_initializer_p (expr
))
7236 ctor
= build_constructor (type
, NULL
);
7238 ctor
= gfc_conv_array_initializer (type
, expr
);
7239 TREE_STATIC (ctor
) = 1;
7242 else if (pointer
|| procptr
)
7244 if (ts
->type
== BT_CLASS
&& !procptr
)
7246 gfc_init_se (&se
, NULL
);
7247 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7248 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7249 TREE_STATIC (se
.expr
) = 1;
7252 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7253 return fold_convert (type
, null_pointer_node
);
7256 gfc_init_se (&se
, NULL
);
7257 se
.want_pointer
= 1;
7258 gfc_conv_expr (&se
, expr
);
7259 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7269 gfc_init_se (&se
, NULL
);
7270 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7271 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7273 gfc_conv_structure (&se
, expr
, 1);
7274 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7275 TREE_STATIC (se
.expr
) = 1;
7280 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
7281 TREE_STATIC (ctor
) = 1;
7286 gfc_init_se (&se
, NULL
);
7287 gfc_conv_constant (&se
, expr
);
7288 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7295 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7301 gfc_array_info
*lss_array
;
7308 gfc_start_block (&block
);
7310 /* Initialize the scalarizer. */
7311 gfc_init_loopinfo (&loop
);
7313 gfc_init_se (&lse
, NULL
);
7314 gfc_init_se (&rse
, NULL
);
7317 rss
= gfc_walk_expr (expr
);
7318 if (rss
== gfc_ss_terminator
)
7319 /* The rhs is scalar. Add a ss for the expression. */
7320 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7322 /* Create a SS for the destination. */
7323 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7325 lss_array
= &lss
->info
->data
.array
;
7326 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7327 lss_array
->descriptor
= dest
;
7328 lss_array
->data
= gfc_conv_array_data (dest
);
7329 lss_array
->offset
= gfc_conv_array_offset (dest
);
7330 for (n
= 0; n
< cm
->as
->rank
; n
++)
7332 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7333 lss_array
->stride
[n
] = gfc_index_one_node
;
7335 mpz_init (lss_array
->shape
[n
]);
7336 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7337 cm
->as
->lower
[n
]->value
.integer
);
7338 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7341 /* Associate the SS with the loop. */
7342 gfc_add_ss_to_loop (&loop
, lss
);
7343 gfc_add_ss_to_loop (&loop
, rss
);
7345 /* Calculate the bounds of the scalarization. */
7346 gfc_conv_ss_startstride (&loop
);
7348 /* Setup the scalarizing loops. */
7349 gfc_conv_loop_setup (&loop
, &expr
->where
);
7351 /* Setup the gfc_se structures. */
7352 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7353 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7356 gfc_mark_ss_chain_used (rss
, 1);
7358 gfc_mark_ss_chain_used (lss
, 1);
7360 /* Start the scalarized loop body. */
7361 gfc_start_scalarized_body (&loop
, &body
);
7363 gfc_conv_tmp_array_ref (&lse
);
7364 if (cm
->ts
.type
== BT_CHARACTER
)
7365 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7367 gfc_conv_expr (&rse
, expr
);
7369 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7370 gfc_add_expr_to_block (&body
, tmp
);
7372 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7374 /* Generate the copying loops. */
7375 gfc_trans_scalarizing_loops (&loop
, &body
);
7377 /* Wrap the whole thing up. */
7378 gfc_add_block_to_block (&block
, &loop
.pre
);
7379 gfc_add_block_to_block (&block
, &loop
.post
);
7381 gcc_assert (lss_array
->shape
!= NULL
);
7382 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7383 gfc_cleanup_loop (&loop
);
7385 return gfc_finish_block (&block
);
7390 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7400 gfc_expr
*arg
= NULL
;
7402 gfc_start_block (&block
);
7403 gfc_init_se (&se
, NULL
);
7405 /* Get the descriptor for the expressions. */
7406 se
.want_pointer
= 0;
7407 gfc_conv_expr_descriptor (&se
, expr
);
7408 gfc_add_block_to_block (&block
, &se
.pre
);
7409 gfc_add_modify (&block
, dest
, se
.expr
);
7411 /* Deal with arrays of derived types with allocatable components. */
7412 if (gfc_bt_struct (cm
->ts
.type
)
7413 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7414 // TODO: Fix caf_mode
7415 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7418 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7419 && CLASS_DATA(cm
)->attr
.allocatable
)
7421 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7422 // TODO: Fix caf_mode
7423 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7428 tmp
= TREE_TYPE (dest
);
7429 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7430 tmp
, expr
->rank
, NULL_TREE
);
7434 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7435 TREE_TYPE(cm
->backend_decl
),
7436 cm
->as
->rank
, NULL_TREE
);
7438 gfc_add_expr_to_block (&block
, tmp
);
7439 gfc_add_block_to_block (&block
, &se
.post
);
7441 if (expr
->expr_type
!= EXPR_VARIABLE
)
7442 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7445 /* We need to know if the argument of a conversion function is a
7446 variable, so that the correct lower bound can be used. */
7447 if (expr
->expr_type
== EXPR_FUNCTION
7448 && expr
->value
.function
.isym
7449 && expr
->value
.function
.isym
->conversion
7450 && expr
->value
.function
.actual
->expr
7451 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7452 arg
= expr
->value
.function
.actual
->expr
;
7454 /* Obtain the array spec of full array references. */
7456 as
= gfc_get_full_arrayspec_from_expr (arg
);
7458 as
= gfc_get_full_arrayspec_from_expr (expr
);
7460 /* Shift the lbound and ubound of temporaries to being unity,
7461 rather than zero, based. Always calculate the offset. */
7462 offset
= gfc_conv_descriptor_offset_get (dest
);
7463 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7464 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7466 for (n
= 0; n
< expr
->rank
; n
++)
7471 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7472 TODO It looks as if gfc_conv_expr_descriptor should return
7473 the correct bounds and that the following should not be
7474 necessary. This would simplify gfc_conv_intrinsic_bound
7476 if (as
&& as
->lower
[n
])
7479 gfc_init_se (&lbse
, NULL
);
7480 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7481 gfc_add_block_to_block (&block
, &lbse
.pre
);
7482 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7486 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7487 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7491 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7494 lbound
= gfc_index_one_node
;
7496 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7498 /* Shift the bounds and set the offset accordingly. */
7499 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7500 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7501 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7502 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7504 gfc_conv_descriptor_ubound_set (&block
, dest
,
7505 gfc_rank_cst
[n
], tmp
);
7506 gfc_conv_descriptor_lbound_set (&block
, dest
,
7507 gfc_rank_cst
[n
], lbound
);
7509 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7510 gfc_conv_descriptor_lbound_get (dest
,
7512 gfc_conv_descriptor_stride_get (dest
,
7514 gfc_add_modify (&block
, tmp2
, tmp
);
7515 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7517 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7522 /* If a conversion expression has a null data pointer
7523 argument, nullify the allocatable component. */
7527 if (arg
->symtree
->n
.sym
->attr
.allocatable
7528 || arg
->symtree
->n
.sym
->attr
.pointer
)
7530 non_null_expr
= gfc_finish_block (&block
);
7531 gfc_start_block (&block
);
7532 gfc_conv_descriptor_data_set (&block
, dest
,
7534 null_expr
= gfc_finish_block (&block
);
7535 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7536 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7537 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7538 return build3_v (COND_EXPR
, tmp
,
7539 null_expr
, non_null_expr
);
7543 return gfc_finish_block (&block
);
7547 /* Allocate or reallocate scalar component, as necessary. */
7550 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7560 tree lhs_cl_size
= NULL_TREE
;
7565 if (!expr2
|| expr2
->rank
)
7568 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7570 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7572 char name
[GFC_MAX_SYMBOL_LEN
+9];
7573 gfc_component
*strlen
;
7574 /* Use the rhs string length and the lhs element size. */
7575 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7576 if (!expr2
->ts
.u
.cl
->backend_decl
)
7578 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7579 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7582 size
= expr2
->ts
.u
.cl
->backend_decl
;
7584 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7586 sprintf (name
, "_%s_length", cm
->name
);
7587 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7588 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7589 gfc_charlen_type_node
,
7590 TREE_OPERAND (comp
, 0),
7591 strlen
->backend_decl
, NULL_TREE
);
7593 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7594 tmp
= TYPE_SIZE_UNIT (tmp
);
7595 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7596 TREE_TYPE (tmp
), tmp
,
7597 fold_convert (TREE_TYPE (tmp
), size
));
7599 else if (cm
->ts
.type
== BT_CLASS
)
7601 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7602 if (expr2
->ts
.type
== BT_DERIVED
)
7604 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7605 size
= TYPE_SIZE_UNIT (tmp
);
7611 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7612 gfc_add_vptr_component (e2vtab
);
7613 gfc_add_size_component (e2vtab
);
7614 gfc_init_se (&se
, NULL
);
7615 gfc_conv_expr (&se
, e2vtab
);
7616 gfc_add_block_to_block (block
, &se
.pre
);
7617 size
= fold_convert (size_type_node
, se
.expr
);
7618 gfc_free_expr (e2vtab
);
7620 size_in_bytes
= size
;
7624 /* Otherwise use the length in bytes of the rhs. */
7625 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7626 size_in_bytes
= size
;
7629 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7630 size_in_bytes
, size_one_node
);
7632 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7634 tmp
= build_call_expr_loc (input_location
,
7635 builtin_decl_explicit (BUILT_IN_CALLOC
),
7636 2, build_one_cst (size_type_node
),
7638 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7639 gfc_add_modify (block
, comp
, tmp
);
7643 tmp
= build_call_expr_loc (input_location
,
7644 builtin_decl_explicit (BUILT_IN_MALLOC
),
7646 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7647 ptr
= gfc_class_data_get (comp
);
7650 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7651 gfc_add_modify (block
, ptr
, tmp
);
7654 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7655 /* Update the lhs character length. */
7656 gfc_add_modify (block
, lhs_cl_size
,
7657 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
7661 /* Assign a single component of a derived type constructor. */
7664 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7665 gfc_symbol
*sym
, bool init
)
7673 gfc_start_block (&block
);
7675 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7677 /* Only care about pointers here, not about allocatables. */
7678 gfc_init_se (&se
, NULL
);
7679 /* Pointer component. */
7680 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7681 && !cm
->attr
.proc_pointer
)
7683 /* Array pointer. */
7684 if (expr
->expr_type
== EXPR_NULL
)
7685 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7688 se
.direct_byref
= 1;
7690 gfc_conv_expr_descriptor (&se
, expr
);
7691 gfc_add_block_to_block (&block
, &se
.pre
);
7692 gfc_add_block_to_block (&block
, &se
.post
);
7697 /* Scalar pointers. */
7698 se
.want_pointer
= 1;
7699 gfc_conv_expr (&se
, expr
);
7700 gfc_add_block_to_block (&block
, &se
.pre
);
7702 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7703 && expr
->symtree
->n
.sym
->attr
.dummy
)
7704 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7706 gfc_add_modify (&block
, dest
,
7707 fold_convert (TREE_TYPE (dest
), se
.expr
));
7708 gfc_add_block_to_block (&block
, &se
.post
);
7711 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7713 /* NULL initialization for CLASS components. */
7714 tmp
= gfc_trans_structure_assign (dest
,
7715 gfc_class_initializer (&cm
->ts
, expr
),
7717 gfc_add_expr_to_block (&block
, tmp
);
7719 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7720 && !cm
->attr
.proc_pointer
)
7722 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7723 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7724 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7726 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7727 gfc_add_expr_to_block (&block
, tmp
);
7731 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7732 gfc_add_expr_to_block (&block
, tmp
);
7735 else if (cm
->ts
.type
== BT_CLASS
7736 && CLASS_DATA (cm
)->attr
.dimension
7737 && CLASS_DATA (cm
)->attr
.allocatable
7738 && expr
->ts
.type
== BT_DERIVED
)
7740 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7741 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7742 tmp
= gfc_class_vptr_get (dest
);
7743 gfc_add_modify (&block
, tmp
,
7744 fold_convert (TREE_TYPE (tmp
), vtab
));
7745 tmp
= gfc_class_data_get (dest
);
7746 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7747 gfc_add_expr_to_block (&block
, tmp
);
7749 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7751 /* NULL initialization for allocatable components. */
7752 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7753 null_pointer_node
));
7755 else if (init
&& (cm
->attr
.allocatable
7756 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7757 && expr
->ts
.type
!= BT_CLASS
)))
7759 /* Take care about non-array allocatable components here. The alloc_*
7760 routine below is motivated by the alloc_scalar_allocatable_for_
7761 assignment() routine, but with the realloc portions removed and
7763 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7768 /* The remainder of these instructions follow the if (cm->attr.pointer)
7769 if (!cm->attr.dimension) part above. */
7770 gfc_init_se (&se
, NULL
);
7771 gfc_conv_expr (&se
, expr
);
7772 gfc_add_block_to_block (&block
, &se
.pre
);
7774 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7775 && expr
->symtree
->n
.sym
->attr
.dummy
)
7776 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7778 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7780 tmp
= gfc_class_data_get (dest
);
7781 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7782 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7783 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7784 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7785 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7788 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7790 /* For deferred strings insert a memcpy. */
7791 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7794 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7795 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7797 : expr
->ts
.u
.cl
->backend_decl
);
7798 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7799 gfc_add_expr_to_block (&block
, tmp
);
7802 gfc_add_modify (&block
, tmp
,
7803 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7804 gfc_add_block_to_block (&block
, &se
.post
);
7806 else if (expr
->ts
.type
== BT_UNION
)
7809 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7810 /* We mark that the entire union should be initialized with a contrived
7811 EXPR_NULL expression at the beginning. */
7812 if (c
!= NULL
&& c
->n
.component
== NULL
7813 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7815 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7816 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7817 gfc_add_expr_to_block (&block
, tmp
);
7818 c
= gfc_constructor_next (c
);
7820 /* The following constructor expression, if any, represents a specific
7821 map intializer, as given by the user. */
7822 if (c
!= NULL
&& c
->expr
!= NULL
)
7824 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7825 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7826 gfc_add_expr_to_block (&block
, tmp
);
7829 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7831 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7833 tree dealloc
= NULL_TREE
;
7834 gfc_init_se (&se
, NULL
);
7835 gfc_conv_expr (&se
, expr
);
7836 gfc_add_block_to_block (&block
, &se
.pre
);
7837 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7838 expression in a temporary variable and deallocate the allocatable
7839 components. Then we can the copy the expression to the result. */
7840 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7841 && expr
->expr_type
!= EXPR_VARIABLE
)
7843 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7844 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7847 gfc_add_modify (&block
, dest
,
7848 fold_convert (TREE_TYPE (dest
), se
.expr
));
7849 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7850 && expr
->expr_type
!= EXPR_NULL
)
7852 // TODO: Fix caf_mode
7853 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7854 dest
, expr
->rank
, 0);
7855 gfc_add_expr_to_block (&block
, tmp
);
7856 if (dealloc
!= NULL_TREE
)
7857 gfc_add_expr_to_block (&block
, dealloc
);
7859 gfc_add_block_to_block (&block
, &se
.post
);
7863 /* Nested constructors. */
7864 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7865 gfc_add_expr_to_block (&block
, tmp
);
7868 else if (gfc_deferred_strlen (cm
, &tmp
))
7872 gcc_assert (strlen
);
7873 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7875 TREE_OPERAND (dest
, 0),
7878 if (expr
->expr_type
== EXPR_NULL
)
7880 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7881 gfc_add_modify (&block
, dest
, tmp
);
7882 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7883 gfc_add_modify (&block
, strlen
, tmp
);
7888 gfc_init_se (&se
, NULL
);
7889 gfc_conv_expr (&se
, expr
);
7890 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7891 tmp
= build_call_expr_loc (input_location
,
7892 builtin_decl_explicit (BUILT_IN_MALLOC
),
7894 gfc_add_modify (&block
, dest
,
7895 fold_convert (TREE_TYPE (dest
), tmp
));
7896 gfc_add_modify (&block
, strlen
,
7897 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
7898 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7899 gfc_add_expr_to_block (&block
, tmp
);
7902 else if (!cm
->attr
.artificial
)
7904 /* Scalar component (excluding deferred parameters). */
7905 gfc_init_se (&se
, NULL
);
7906 gfc_init_se (&lse
, NULL
);
7908 gfc_conv_expr (&se
, expr
);
7909 if (cm
->ts
.type
== BT_CHARACTER
)
7910 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7912 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7913 gfc_add_expr_to_block (&block
, tmp
);
7915 return gfc_finish_block (&block
);
7918 /* Assign a derived type constructor to a variable. */
7921 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7930 gfc_start_block (&block
);
7931 cm
= expr
->ts
.u
.derived
->components
;
7933 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7934 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7935 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7939 gfc_init_se (&se
, NULL
);
7940 gfc_init_se (&lse
, NULL
);
7941 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7943 gfc_add_modify (&block
, lse
.expr
,
7944 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7946 return gfc_finish_block (&block
);
7950 gfc_init_se (&se
, NULL
);
7952 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7953 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7955 /* Skip absent members in default initializers. */
7956 if (!c
->expr
&& !cm
->attr
.allocatable
)
7959 /* Register the component with the caf-lib before it is initialized.
7960 Register only allocatable components, that are not coarray'ed
7961 components (%comp[*]). Only register when the constructor is not the
7963 if (coarray
&& !cm
->attr
.codimension
7964 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7965 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7967 tree token
, desc
, size
;
7968 bool is_array
= cm
->ts
.type
== BT_CLASS
7969 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7971 field
= cm
->backend_decl
;
7972 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7973 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7974 if (cm
->ts
.type
== BT_CLASS
)
7975 field
= gfc_class_data_get (field
);
7977 token
= is_array
? gfc_conv_descriptor_token (field
)
7978 : fold_build3_loc (input_location
, COMPONENT_REF
,
7979 TREE_TYPE (cm
->caf_token
), dest
,
7980 cm
->caf_token
, NULL_TREE
);
7984 /* The _caf_register routine looks at the rank of the array
7985 descriptor to decide whether the data registered is an array
7987 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7989 /* When the rank is not known just set a positive rank, which
7990 suffices to recognize the data as array. */
7993 size
= build_zero_cst (size_type_node
);
7995 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
7996 build_int_cst (signed_char_type_node
, rank
));
8000 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
8001 cm
->ts
.type
== BT_CLASS
8002 ? CLASS_DATA (cm
)->attr
8004 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
8006 gfc_add_block_to_block (&block
, &se
.pre
);
8007 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
8008 7, size
, build_int_cst (
8010 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
8011 gfc_build_addr_expr (pvoid_type_node
,
8013 gfc_build_addr_expr (NULL_TREE
, desc
),
8014 null_pointer_node
, null_pointer_node
,
8016 gfc_add_expr_to_block (&block
, tmp
);
8018 field
= cm
->backend_decl
;
8019 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
8020 dest
, field
, NULL_TREE
);
8023 gfc_expr
*e
= gfc_get_null_expr (NULL
);
8024 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
8029 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
8030 expr
->ts
.u
.derived
, init
);
8031 gfc_add_expr_to_block (&block
, tmp
);
8033 return gfc_finish_block (&block
);
8037 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
8038 gfc_component
*un
, gfc_expr
*init
)
8040 gfc_constructor
*ctor
;
8042 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
8045 ctor
= gfc_constructor_first (init
->value
.constructor
);
8047 if (ctor
== NULL
|| ctor
->expr
== NULL
)
8050 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
8052 /* If we have an 'initialize all' constructor, do it first. */
8053 if (ctor
->expr
->expr_type
== EXPR_NULL
)
8055 tree union_type
= TREE_TYPE (un
->backend_decl
);
8056 tree val
= build_constructor (union_type
, NULL
);
8057 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8058 ctor
= gfc_constructor_next (ctor
);
8061 /* Add the map initializer on top. */
8062 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
8064 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
8065 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
8066 TREE_TYPE (un
->backend_decl
),
8067 un
->attr
.dimension
, un
->attr
.pointer
,
8068 un
->attr
.proc_pointer
);
8069 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
8073 /* Build an expression for a constructor. If init is nonzero then
8074 this is part of a static variable initializer. */
8077 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
8084 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8086 gcc_assert (se
->ss
== NULL
);
8087 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8088 type
= gfc_typenode_for_spec (&expr
->ts
);
8092 /* Create a temporary variable and fill it in. */
8093 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
8094 /* The symtree in expr is NULL, if the code to generate is for
8095 initializing the static members only. */
8096 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
8098 gfc_add_expr_to_block (&se
->pre
, tmp
);
8102 cm
= expr
->ts
.u
.derived
->components
;
8104 for (c
= gfc_constructor_first (expr
->value
.constructor
);
8105 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
8107 /* Skip absent members in default initializers and allocatable
8108 components. Although the latter have a default initializer
8109 of EXPR_NULL,... by default, the static nullify is not needed
8110 since this is done every time we come into scope. */
8111 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
8114 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
8115 && strcmp (cm
->name
, "_extends") == 0
8116 && cm
->initializer
->symtree
)
8120 vtabs
= cm
->initializer
->symtree
->n
.sym
;
8121 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
8122 vtab
= unshare_expr_without_location (vtab
);
8123 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
8125 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
8127 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
8128 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8129 fold_convert (TREE_TYPE (cm
->backend_decl
),
8132 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
8133 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
8134 fold_convert (TREE_TYPE (cm
->backend_decl
),
8135 integer_zero_node
));
8136 else if (cm
->ts
.type
== BT_UNION
)
8137 gfc_conv_union_initializer (v
, cm
, c
->expr
);
8140 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
8141 TREE_TYPE (cm
->backend_decl
),
8142 cm
->attr
.dimension
, cm
->attr
.pointer
,
8143 cm
->attr
.proc_pointer
);
8144 val
= unshare_expr_without_location (val
);
8146 /* Append it to the constructor list. */
8147 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
8151 se
->expr
= build_constructor (type
, v
);
8153 TREE_CONSTANT (se
->expr
) = 1;
8157 /* Translate a substring expression. */
8160 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
8166 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
8168 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
8169 expr
->value
.character
.length
,
8170 expr
->value
.character
.string
);
8172 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
8173 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
8176 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
8180 /* Entry point for expression translation. Evaluates a scalar quantity.
8181 EXPR is the expression to be translated, and SE is the state structure if
8182 called from within the scalarized. */
8185 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
8190 if (ss
&& ss
->info
->expr
== expr
8191 && (ss
->info
->type
== GFC_SS_SCALAR
8192 || ss
->info
->type
== GFC_SS_REFERENCE
))
8194 gfc_ss_info
*ss_info
;
8197 /* Substitute a scalar expression evaluated outside the scalarization
8199 se
->expr
= ss_info
->data
.scalar
.value
;
8200 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
8201 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8203 se
->string_length
= ss_info
->string_length
;
8204 gfc_advance_se_ss_chain (se
);
8208 /* We need to convert the expressions for the iso_c_binding derived types.
8209 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8210 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8211 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8212 updated to be an integer with a kind equal to the size of a (void *). */
8213 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
8214 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
8216 if (expr
->expr_type
== EXPR_VARIABLE
8217 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
8218 || expr
->symtree
->n
.sym
->intmod_sym_id
8219 == ISOCBINDING_NULL_FUNPTR
))
8221 /* Set expr_type to EXPR_NULL, which will result in
8222 null_pointer_node being used below. */
8223 expr
->expr_type
= EXPR_NULL
;
8227 /* Update the type/kind of the expression to be what the new
8228 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8229 expr
->ts
.type
= BT_INTEGER
;
8230 expr
->ts
.f90_type
= BT_VOID
;
8231 expr
->ts
.kind
= gfc_index_integer_kind
;
8235 gfc_fix_class_refs (expr
);
8237 switch (expr
->expr_type
)
8240 gfc_conv_expr_op (se
, expr
);
8244 gfc_conv_function_expr (se
, expr
);
8248 gfc_conv_constant (se
, expr
);
8252 gfc_conv_variable (se
, expr
);
8256 se
->expr
= null_pointer_node
;
8259 case EXPR_SUBSTRING
:
8260 gfc_conv_substring_expr (se
, expr
);
8263 case EXPR_STRUCTURE
:
8264 gfc_conv_structure (se
, expr
, 0);
8268 gfc_conv_array_constructor_expr (se
, expr
);
8277 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8278 of an assignment. */
8280 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8282 gfc_conv_expr (se
, expr
);
8283 /* All numeric lvalues should have empty post chains. If not we need to
8284 figure out a way of rewriting an lvalue so that it has no post chain. */
8285 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8288 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8289 numeric expressions. Used for scalar values where inserting cleanup code
8292 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8296 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8297 gfc_conv_expr (se
, expr
);
8300 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8301 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8303 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8307 /* Helper to translate an expression and convert it to a particular type. */
8309 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8311 gfc_conv_expr_val (se
, expr
);
8312 se
->expr
= convert (type
, se
->expr
);
8316 /* Converts an expression so that it can be passed by reference. Scalar
8320 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8326 if (ss
&& ss
->info
->expr
== expr
8327 && ss
->info
->type
== GFC_SS_REFERENCE
)
8329 /* Returns a reference to the scalar evaluated outside the loop
8331 gfc_conv_expr (se
, expr
);
8333 if (expr
->ts
.type
== BT_CHARACTER
8334 && expr
->expr_type
!= EXPR_FUNCTION
)
8335 gfc_conv_string_parameter (se
);
8337 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8342 if (expr
->ts
.type
== BT_CHARACTER
)
8344 gfc_conv_expr (se
, expr
);
8345 gfc_conv_string_parameter (se
);
8349 if (expr
->expr_type
== EXPR_VARIABLE
)
8351 se
->want_pointer
= 1;
8352 gfc_conv_expr (se
, expr
);
8355 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8356 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8357 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8360 else if (add_clobber
&& expr
->ref
== NULL
)
8364 /* FIXME: This fails if var is passed by reference, see PR
8366 var
= expr
->symtree
->n
.sym
->backend_decl
;
8367 clobber
= build_clobber (TREE_TYPE (var
));
8368 gfc_add_modify (&se
->pre
, var
, clobber
);
8373 if (expr
->expr_type
== EXPR_FUNCTION
8374 && ((expr
->value
.function
.esym
8375 && expr
->value
.function
.esym
->result
->attr
.pointer
8376 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8377 || (!expr
->value
.function
.esym
&& !expr
->ref
8378 && expr
->symtree
->n
.sym
->attr
.pointer
8379 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8381 se
->want_pointer
= 1;
8382 gfc_conv_expr (se
, expr
);
8383 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8384 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8389 gfc_conv_expr (se
, expr
);
8391 /* Create a temporary var to hold the value. */
8392 if (TREE_CONSTANT (se
->expr
))
8394 tree tmp
= se
->expr
;
8395 STRIP_TYPE_NOPS (tmp
);
8396 var
= build_decl (input_location
,
8397 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8398 DECL_INITIAL (var
) = tmp
;
8399 TREE_STATIC (var
) = 1;
8404 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8405 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8408 if (!expr
->must_finalize
)
8409 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8411 /* Take the address of that value. */
8412 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8416 /* Get the _len component for an unlimited polymorphic expression. */
8419 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8422 gfc_ref
*ref
= expr
->ref
;
8424 gfc_init_se (&se
, NULL
);
8425 while (ref
&& ref
->next
)
8427 gfc_add_len_component (expr
);
8428 gfc_conv_expr (&se
, expr
);
8429 gfc_add_block_to_block (block
, &se
.pre
);
8430 gcc_assert (se
.post
.head
== NULL_TREE
);
8433 gfc_free_ref_list (ref
->next
);
8438 gfc_free_ref_list (expr
->ref
);
8445 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8446 statement-list outside of the scalarizer-loop. When code is generated, that
8447 depends on the scalarized expression, it is added to RSE.PRE.
8448 Returns le's _vptr tree and when set the len expressions in to_lenp and
8449 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8453 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8454 gfc_expr
* re
, gfc_se
*rse
,
8455 tree
* to_lenp
, tree
* from_lenp
)
8458 gfc_expr
* vptr_expr
;
8459 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8460 bool set_vptr
= false, temp_rhs
= false;
8461 stmtblock_t
*pre
= block
;
8463 /* Create a temporary for complicated expressions. */
8464 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8465 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8467 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8469 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8474 /* Get the _vptr for the left-hand side expression. */
8475 gfc_init_se (&se
, NULL
);
8476 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8477 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8479 /* Care about _len for unlimited polymorphic entities. */
8480 if (UNLIMITED_POLY (vptr_expr
)
8481 || (vptr_expr
->ts
.type
== BT_DERIVED
8482 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8483 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8484 gfc_add_vptr_component (vptr_expr
);
8488 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8489 se
.want_pointer
= 1;
8490 gfc_conv_expr (&se
, vptr_expr
);
8491 gfc_free_expr (vptr_expr
);
8492 gfc_add_block_to_block (block
, &se
.pre
);
8493 gcc_assert (se
.post
.head
== NULL_TREE
);
8495 STRIP_NOPS (lhs_vptr
);
8497 /* Set the _vptr only when the left-hand side of the assignment is a
8501 /* Get the vptr from the rhs expression only, when it is variable.
8502 Functions are expected to be assigned to a temporary beforehand. */
8503 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8504 ? gfc_find_and_cut_at_last_class_ref (re
)
8506 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8508 if (to_len
!= NULL_TREE
)
8510 /* Get the _len information from the rhs. */
8511 if (UNLIMITED_POLY (vptr_expr
)
8512 || (vptr_expr
->ts
.type
== BT_DERIVED
8513 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8514 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8516 gfc_add_vptr_component (vptr_expr
);
8520 if (re
->expr_type
== EXPR_VARIABLE
8521 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8522 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8523 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8524 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8525 re
->symtree
->n
.sym
->backend_decl
))))
8528 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8529 re
->symtree
->n
.sym
->backend_decl
));
8531 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8532 re
->symtree
->n
.sym
->backend_decl
));
8534 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8537 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8538 if (UNLIMITED_POLY (re
))
8539 from_len
= gfc_class_len_get (rse
->expr
);
8541 else if (re
->expr_type
!= EXPR_NULL
)
8542 /* Only when rhs is non-NULL use its declared type for vptr
8544 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8546 /* When the rhs is NULL use the vtab of lhs' declared type. */
8547 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8552 gfc_init_se (&se
, NULL
);
8553 se
.want_pointer
= 1;
8554 gfc_conv_expr (&se
, vptr_expr
);
8555 gfc_free_expr (vptr_expr
);
8556 gfc_add_block_to_block (block
, &se
.pre
);
8557 gcc_assert (se
.post
.head
== NULL_TREE
);
8559 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8562 if (to_len
!= NULL_TREE
)
8564 /* The _len component needs to be set. Figure how to get the
8565 value of the right-hand side. */
8566 if (from_len
== NULL_TREE
)
8568 if (rse
->string_length
!= NULL_TREE
)
8569 from_len
= rse
->string_length
;
8570 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8572 from_len
= gfc_get_expr_charlen (re
);
8573 gfc_init_se (&se
, NULL
);
8574 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8575 gfc_add_block_to_block (block
, &se
.pre
);
8576 gcc_assert (se
.post
.head
== NULL_TREE
);
8577 from_len
= gfc_evaluate_now (se
.expr
, block
);
8580 from_len
= build_zero_cst (gfc_charlen_type_node
);
8582 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8587 /* Return the _len trees only, when requested. */
8591 *from_lenp
= from_len
;
8596 /* Assign tokens for pointer components. */
8599 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8602 symbol_attribute lhs_attr
, rhs_attr
;
8603 tree tmp
, lhs_tok
, rhs_tok
;
8604 /* Flag to indicated component refs on the rhs. */
8607 lhs_attr
= gfc_caf_attr (expr1
);
8608 if (expr2
->expr_type
!= EXPR_NULL
)
8610 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8611 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8613 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8614 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8617 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8621 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8622 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8625 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8627 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8628 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8631 else if (lhs_attr
.codimension
)
8633 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8634 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8635 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8636 lhs_tok
, null_pointer_node
);
8637 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8641 /* Indentify class valued proc_pointer assignments. */
8644 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8649 while (ref
&& ref
->next
)
8652 return ref
&& ref
->type
== REF_COMPONENT
8653 && ref
->u
.c
.component
->attr
.proc_pointer
8654 && expr2
->expr_type
== EXPR_VARIABLE
8655 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8659 /* Do everything that is needed for a CLASS function expr2. */
8662 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8663 gfc_expr
*expr1
, gfc_expr
*expr2
)
8665 tree expr1_vptr
= NULL_TREE
;
8668 gfc_conv_function_expr (rse
, expr2
);
8669 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8671 if (expr1
->ts
.type
!= BT_CLASS
)
8672 rse
->expr
= gfc_class_data_get (rse
->expr
);
8675 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8678 gfc_add_block_to_block (block
, &rse
->pre
);
8679 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8680 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8682 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8683 fold_convert (TREE_TYPE (expr1_vptr
),
8684 gfc_class_vptr_get (tmp
)));
8685 rse
->expr
= gfc_class_data_get (tmp
);
8693 gfc_trans_pointer_assign (gfc_code
* code
)
8695 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8699 /* Generate code for a pointer assignment. */
8702 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8709 tree expr1_vptr
= NULL_TREE
;
8710 bool scalar
, non_proc_pointer_assign
;
8713 gfc_start_block (&block
);
8715 gfc_init_se (&lse
, NULL
);
8717 /* Usually testing whether this is not a proc pointer assignment. */
8718 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8720 /* Check whether the expression is a scalar or not; we cannot use
8721 expr1->rank as it can be nonzero for proc pointers. */
8722 ss
= gfc_walk_expr (expr1
);
8723 scalar
= ss
== gfc_ss_terminator
;
8725 gfc_free_ss_chain (ss
);
8727 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8728 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8730 gfc_add_data_component (expr2
);
8731 /* The following is required as gfc_add_data_component doesn't
8732 update ts.type if there is a tailing REF_ARRAY. */
8733 expr2
->ts
.type
= BT_DERIVED
;
8738 /* Scalar pointers. */
8739 lse
.want_pointer
= 1;
8740 gfc_conv_expr (&lse
, expr1
);
8741 gfc_init_se (&rse
, NULL
);
8742 rse
.want_pointer
= 1;
8743 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8744 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8746 gfc_conv_expr (&rse
, expr2
);
8748 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8750 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8752 lse
.expr
= gfc_class_data_get (lse
.expr
);
8755 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8756 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8757 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8760 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8761 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8762 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8765 gfc_add_block_to_block (&block
, &lse
.pre
);
8766 gfc_add_block_to_block (&block
, &rse
.pre
);
8768 /* Check character lengths if character expression. The test is only
8769 really added if -fbounds-check is enabled. Exclude deferred
8770 character length lefthand sides. */
8771 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8772 && !expr1
->ts
.deferred
8773 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8774 && !gfc_is_proc_ptr_comp (expr1
))
8776 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8777 gcc_assert (lse
.string_length
&& rse
.string_length
);
8778 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8779 lse
.string_length
, rse
.string_length
,
8783 /* The assignment to an deferred character length sets the string
8784 length to that of the rhs. */
8785 if (expr1
->ts
.deferred
)
8787 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8788 gfc_add_modify (&block
, lse
.string_length
,
8789 fold_convert (TREE_TYPE (lse
.string_length
),
8790 rse
.string_length
));
8791 else if (lse
.string_length
!= NULL
)
8792 gfc_add_modify (&block
, lse
.string_length
,
8793 build_zero_cst (TREE_TYPE (lse
.string_length
)));
8796 gfc_add_modify (&block
, lse
.expr
,
8797 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8799 /* Also set the tokens for pointer components in derived typed
8801 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8802 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8804 gfc_add_block_to_block (&block
, &rse
.post
);
8805 gfc_add_block_to_block (&block
, &lse
.post
);
8812 tree strlen_rhs
= NULL_TREE
;
8814 /* Array pointer. Find the last reference on the LHS and if it is an
8815 array section ref, we're dealing with bounds remapping. In this case,
8816 set it to AR_FULL so that gfc_conv_expr_descriptor does
8817 not see it and process the bounds remapping afterwards explicitly. */
8818 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8819 if (!remap
->next
&& remap
->type
== REF_ARRAY
8820 && remap
->u
.ar
.type
== AR_SECTION
)
8822 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8824 gfc_init_se (&lse
, NULL
);
8826 lse
.descriptor_only
= 1;
8827 gfc_conv_expr_descriptor (&lse
, expr1
);
8828 strlen_lhs
= lse
.string_length
;
8831 if (expr2
->expr_type
== EXPR_NULL
)
8833 /* Just set the data pointer to null. */
8834 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8836 else if (rank_remap
)
8838 /* If we are rank-remapping, just get the RHS's descriptor and
8839 process this later on. */
8840 gfc_init_se (&rse
, NULL
);
8841 rse
.direct_byref
= 1;
8842 rse
.byref_noassign
= 1;
8844 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8845 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8847 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8849 tree bound
[GFC_MAX_DIMENSIONS
];
8852 for (i
= 0; i
< expr2
->rank
; i
++)
8853 bound
[i
] = NULL_TREE
;
8854 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8855 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8857 GFC_ARRAY_POINTER_CONT
, false);
8858 tmp
= gfc_create_var (tmp
, "ptrtemp");
8859 rse
.descriptor_only
= 0;
8861 rse
.direct_byref
= 1;
8862 gfc_conv_expr_descriptor (&rse
, expr2
);
8863 strlen_rhs
= rse
.string_length
;
8868 gfc_conv_expr_descriptor (&rse
, expr2
);
8869 strlen_rhs
= rse
.string_length
;
8870 if (expr1
->ts
.type
== BT_CLASS
)
8871 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8876 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8878 /* Assign directly to the LHS's descriptor. */
8879 lse
.descriptor_only
= 0;
8880 lse
.direct_byref
= 1;
8881 gfc_conv_expr_descriptor (&lse
, expr2
);
8882 strlen_rhs
= lse
.string_length
;
8884 if (expr1
->ts
.type
== BT_CLASS
)
8886 rse
.expr
= NULL_TREE
;
8887 rse
.string_length
= NULL_TREE
;
8888 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8894 /* If the target is not a whole array, use the target array
8895 reference for remap. */
8896 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8897 if (remap
->type
== REF_ARRAY
8898 && remap
->u
.ar
.type
== AR_FULL
8903 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8905 gfc_init_se (&rse
, NULL
);
8906 rse
.want_pointer
= 1;
8907 gfc_conv_function_expr (&rse
, expr2
);
8908 if (expr1
->ts
.type
!= BT_CLASS
)
8910 rse
.expr
= gfc_class_data_get (rse
.expr
);
8911 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8912 /* Set the lhs span. */
8913 tmp
= TREE_TYPE (rse
.expr
);
8914 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8915 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8916 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8920 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8923 gfc_add_block_to_block (&block
, &rse
.pre
);
8924 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8925 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8927 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8928 fold_convert (TREE_TYPE (expr1_vptr
),
8929 gfc_class_vptr_get (tmp
)));
8930 rse
.expr
= gfc_class_data_get (tmp
);
8931 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8936 /* Assign to a temporary descriptor and then copy that
8937 temporary to the pointer. */
8938 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8939 lse
.descriptor_only
= 0;
8941 lse
.direct_byref
= 1;
8942 gfc_conv_expr_descriptor (&lse
, expr2
);
8943 strlen_rhs
= lse
.string_length
;
8944 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8947 gfc_add_block_to_block (&block
, &lse
.pre
);
8949 gfc_add_block_to_block (&block
, &rse
.pre
);
8951 /* If we do bounds remapping, update LHS descriptor accordingly. */
8955 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8959 /* Do rank remapping. We already have the RHS's descriptor
8960 converted in rse and now have to build the correct LHS
8961 descriptor for it. */
8963 tree dtype
, data
, span
;
8965 tree lbound
, ubound
;
8968 dtype
= gfc_conv_descriptor_dtype (desc
);
8969 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8970 gfc_add_modify (&block
, dtype
, tmp
);
8972 /* Copy data pointer. */
8973 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8974 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8976 /* Copy the span. */
8977 if (TREE_CODE (rse
.expr
) == VAR_DECL
8978 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8979 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8982 tmp
= TREE_TYPE (rse
.expr
);
8983 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8984 span
= fold_convert (gfc_array_index_type
, tmp
);
8986 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8988 /* Copy offset but adjust it such that it would correspond
8989 to a lbound of zero. */
8990 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8991 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8993 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8995 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8997 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8998 gfc_array_index_type
, stride
, lbound
);
8999 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
9000 gfc_array_index_type
, offs
, tmp
);
9002 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9004 /* Set the bounds as declared for the LHS and calculate strides as
9005 well as another offset update accordingly. */
9006 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
9008 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
9013 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
9015 /* Convert declared bounds. */
9016 gfc_init_se (&lower_se
, NULL
);
9017 gfc_init_se (&upper_se
, NULL
);
9018 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
9019 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
9021 gfc_add_block_to_block (&block
, &lower_se
.pre
);
9022 gfc_add_block_to_block (&block
, &upper_se
.pre
);
9024 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
9025 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
9027 lbound
= gfc_evaluate_now (lbound
, &block
);
9028 ubound
= gfc_evaluate_now (ubound
, &block
);
9030 gfc_add_block_to_block (&block
, &lower_se
.post
);
9031 gfc_add_block_to_block (&block
, &upper_se
.post
);
9033 /* Set bounds in descriptor. */
9034 gfc_conv_descriptor_lbound_set (&block
, desc
,
9035 gfc_rank_cst
[dim
], lbound
);
9036 gfc_conv_descriptor_ubound_set (&block
, desc
,
9037 gfc_rank_cst
[dim
], ubound
);
9040 stride
= gfc_evaluate_now (stride
, &block
);
9041 gfc_conv_descriptor_stride_set (&block
, desc
,
9042 gfc_rank_cst
[dim
], stride
);
9044 /* Update offset. */
9045 offs
= gfc_conv_descriptor_offset_get (desc
);
9046 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9047 gfc_array_index_type
, lbound
, stride
);
9048 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
9049 gfc_array_index_type
, offs
, tmp
);
9050 offs
= gfc_evaluate_now (offs
, &block
);
9051 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
9053 /* Update stride. */
9054 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
9055 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
9056 gfc_array_index_type
, stride
, tmp
);
9061 /* Bounds remapping. Just shift the lower bounds. */
9063 gcc_assert (expr1
->rank
== expr2
->rank
);
9065 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
9069 gcc_assert (!remap
->u
.ar
.end
[dim
]);
9070 gfc_init_se (&lbound_se
, NULL
);
9071 if (remap
->u
.ar
.start
[dim
])
9073 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
9074 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
9077 /* This remap arises from a target that is not a whole
9078 array. The start expressions will be NULL but we need
9079 the lbounds to be one. */
9080 lbound_se
.expr
= gfc_index_one_node
;
9081 gfc_conv_shift_descriptor_lbound (&block
, desc
,
9082 dim
, lbound_se
.expr
);
9083 gfc_add_block_to_block (&block
, &lbound_se
.post
);
9088 /* Check string lengths if applicable. The check is only really added
9089 to the output code if -fbounds-check is enabled. */
9090 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
9092 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9093 gcc_assert (strlen_lhs
&& strlen_rhs
);
9094 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9095 strlen_lhs
, strlen_rhs
, &block
);
9098 /* If rank remapping was done, check with -fcheck=bounds that
9099 the target is at least as large as the pointer. */
9100 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
9106 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
9107 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
9109 lsize
= gfc_evaluate_now (lsize
, &block
);
9110 rsize
= gfc_evaluate_now (rsize
, &block
);
9111 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
9114 msg
= _("Target of rank remapping is too small (%ld < %ld)");
9115 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
9119 if (expr1
->ts
.type
== BT_CHARACTER
9120 && expr1
->symtree
->n
.sym
->ts
.deferred
9121 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
9122 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
9124 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
9125 if (expr2
->expr_type
!= EXPR_NULL
)
9126 gfc_add_modify (&block
, tmp
,
9127 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
9129 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
9132 gfc_add_block_to_block (&block
, &lse
.post
);
9134 gfc_add_block_to_block (&block
, &rse
.post
);
9137 return gfc_finish_block (&block
);
9141 /* Makes sure se is suitable for passing as a function string parameter. */
9142 /* TODO: Need to check all callers of this function. It may be abused. */
9145 gfc_conv_string_parameter (gfc_se
* se
)
9149 if (TREE_CODE (se
->expr
) == STRING_CST
)
9151 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
9152 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9156 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
9158 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
9160 type
= TREE_TYPE (se
->expr
);
9161 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
9165 type
= gfc_get_character_type_len (gfc_default_character_kind
,
9167 type
= build_pointer_type (type
);
9168 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
9172 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
9176 /* Generate code for assignment of scalar variables. Includes character
9177 strings and derived types with allocatable components.
9178 If you know that the LHS has no allocations, set dealloc to false.
9180 DEEP_COPY has no effect if the typespec TS is not a derived type with
9181 allocatable components. Otherwise, if it is set, an explicit copy of each
9182 allocatable component is made. This is necessary as a simple copy of the
9183 whole object would copy array descriptors as is, so that the lhs's
9184 allocatable components would point to the rhs's after the assignment.
9185 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9186 necessary if the rhs is a non-pointer function, as the allocatable components
9187 are not accessible by other means than the function's result after the
9188 function has returned. It is even more subtle when temporaries are involved,
9189 as the two following examples show:
9190 1. When we evaluate an array constructor, a temporary is created. Thus
9191 there is theoretically no alias possible. However, no deep copy is
9192 made for this temporary, so that if the constructor is made of one or
9193 more variable with allocatable components, those components still point
9194 to the variable's: DEEP_COPY should be set for the assignment from the
9195 temporary to the lhs in that case.
9196 2. When assigning a scalar to an array, we evaluate the scalar value out
9197 of the loop, store it into a temporary variable, and assign from that.
9198 In that case, deep copying when assigning to the temporary would be a
9199 waste of resources; however deep copies should happen when assigning from
9200 the temporary to each array element: again DEEP_COPY should be set for
9201 the assignment from the temporary to the lhs. */
9204 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
9205 bool deep_copy
, bool dealloc
, bool in_coarray
)
9211 gfc_init_block (&block
);
9213 if (ts
.type
== BT_CHARACTER
)
9218 if (lse
->string_length
!= NULL_TREE
)
9220 gfc_conv_string_parameter (lse
);
9221 gfc_add_block_to_block (&block
, &lse
->pre
);
9222 llen
= lse
->string_length
;
9225 if (rse
->string_length
!= NULL_TREE
)
9227 gfc_conv_string_parameter (rse
);
9228 gfc_add_block_to_block (&block
, &rse
->pre
);
9229 rlen
= rse
->string_length
;
9232 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
9233 rse
->expr
, ts
.kind
);
9235 else if (gfc_bt_struct (ts
.type
)
9236 && (ts
.u
.derived
->attr
.alloc_comp
9237 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
9239 tree tmp_var
= NULL_TREE
;
9242 /* Are the rhs and the lhs the same? */
9245 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9246 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
9247 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
9248 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
9251 /* Deallocate the lhs allocated components as long as it is not
9252 the same as the rhs. This must be done following the assignment
9253 to prevent deallocating data that could be used in the rhs
9257 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
9258 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9260 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9262 gfc_add_expr_to_block (&lse
->post
, tmp
);
9265 gfc_add_block_to_block (&block
, &rse
->pre
);
9266 gfc_add_block_to_block (&block
, &lse
->pre
);
9268 gfc_add_modify (&block
, lse
->expr
,
9269 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9271 /* Restore pointer address of coarray components. */
9272 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9274 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9275 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9277 gfc_add_expr_to_block (&block
, tmp
);
9280 /* Do a deep copy if the rhs is a variable, if it is not the
9284 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9285 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9286 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9288 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9290 gfc_add_expr_to_block (&block
, tmp
);
9293 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
9295 gfc_add_block_to_block (&block
, &lse
->pre
);
9296 gfc_add_block_to_block (&block
, &rse
->pre
);
9297 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9298 TREE_TYPE (lse
->expr
), rse
->expr
);
9299 gfc_add_modify (&block
, lse
->expr
, tmp
);
9303 gfc_add_block_to_block (&block
, &lse
->pre
);
9304 gfc_add_block_to_block (&block
, &rse
->pre
);
9306 gfc_add_modify (&block
, lse
->expr
,
9307 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9310 gfc_add_block_to_block (&block
, &lse
->post
);
9311 gfc_add_block_to_block (&block
, &rse
->post
);
9313 return gfc_finish_block (&block
);
9317 /* There are quite a lot of restrictions on the optimisation in using an
9318 array function assign without a temporary. */
9321 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9324 bool seen_array_ref
;
9326 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9328 /* Play it safe with class functions assigned to a derived type. */
9329 if (gfc_is_class_array_function (expr2
)
9330 && expr1
->ts
.type
== BT_DERIVED
)
9333 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9334 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9337 /* Elemental functions are scalarized so that they don't need a
9338 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9339 they would need special treatment in gfc_trans_arrayfunc_assign. */
9340 if (expr2
->value
.function
.esym
!= NULL
9341 && expr2
->value
.function
.esym
->attr
.elemental
)
9344 /* Need a temporary if rhs is not FULL or a contiguous section. */
9345 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9348 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9349 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9352 /* Functions returning pointers or allocatables need temporaries. */
9353 c
= expr2
->value
.function
.esym
9354 ? (expr2
->value
.function
.esym
->attr
.pointer
9355 || expr2
->value
.function
.esym
->attr
.allocatable
)
9356 : (expr2
->symtree
->n
.sym
->attr
.pointer
9357 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9361 /* Character array functions need temporaries unless the
9362 character lengths are the same. */
9363 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9365 if (expr1
->ts
.u
.cl
->length
== NULL
9366 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9369 if (expr2
->ts
.u
.cl
->length
== NULL
9370 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9373 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9374 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9378 /* Check that no LHS component references appear during an array
9379 reference. This is needed because we do not have the means to
9380 span any arbitrary stride with an array descriptor. This check
9381 is not needed for the rhs because the function result has to be
9383 seen_array_ref
= false;
9384 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9386 if (ref
->type
== REF_ARRAY
)
9387 seen_array_ref
= true;
9388 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9392 /* Check for a dependency. */
9393 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9394 expr2
->value
.function
.esym
,
9395 expr2
->value
.function
.actual
,
9399 /* If we have reached here with an intrinsic function, we do not
9400 need a temporary except in the particular case that reallocation
9401 on assignment is active and the lhs is allocatable and a target. */
9402 if (expr2
->value
.function
.isym
)
9403 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9405 /* If the LHS is a dummy, we need a temporary if it is not
9407 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9410 /* If the lhs has been host_associated, is in common, a pointer or is
9411 a target and the function is not using a RESULT variable, aliasing
9412 can occur and a temporary is needed. */
9413 if ((sym
->attr
.host_assoc
9414 || sym
->attr
.in_common
9415 || sym
->attr
.pointer
9416 || sym
->attr
.cray_pointee
9417 || sym
->attr
.target
)
9418 && expr2
->symtree
!= NULL
9419 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9422 /* A PURE function can unconditionally be called without a temporary. */
9423 if (expr2
->value
.function
.esym
!= NULL
9424 && expr2
->value
.function
.esym
->attr
.pure
)
9427 /* Implicit_pure functions are those which could legally be declared
9429 if (expr2
->value
.function
.esym
!= NULL
9430 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9433 if (!sym
->attr
.use_assoc
9434 && !sym
->attr
.in_common
9435 && !sym
->attr
.pointer
9436 && !sym
->attr
.target
9437 && !sym
->attr
.cray_pointee
9438 && expr2
->value
.function
.esym
)
9440 /* A temporary is not needed if the function is not contained and
9441 the variable is local or host associated and not a pointer or
9443 if (!expr2
->value
.function
.esym
->attr
.contained
)
9446 /* A temporary is not needed if the lhs has never been host
9447 associated and the procedure is contained. */
9448 else if (!sym
->attr
.host_assoc
)
9451 /* A temporary is not needed if the variable is local and not
9452 a pointer, a target or a result. */
9454 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9458 /* Default to temporary use. */
9463 /* Provide the loop info so that the lhs descriptor can be built for
9464 reallocatable assignments from extrinsic function calls. */
9467 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9470 /* Signal that the function call should not be made by
9471 gfc_conv_loop_setup. */
9472 se
->ss
->is_alloc_lhs
= 1;
9473 gfc_init_loopinfo (loop
);
9474 gfc_add_ss_to_loop (loop
, *ss
);
9475 gfc_add_ss_to_loop (loop
, se
->ss
);
9476 gfc_conv_ss_startstride (loop
);
9477 gfc_conv_loop_setup (loop
, where
);
9478 gfc_copy_loopinfo_to_se (se
, loop
);
9479 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9480 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9481 se
->ss
->is_alloc_lhs
= 0;
9485 /* For assignment to a reallocatable lhs from intrinsic functions,
9486 replace the se.expr (ie. the result) with a temporary descriptor.
9487 Null the data field so that the library allocates space for the
9488 result. Free the data of the original descriptor after the function,
9489 in case it appears in an argument expression and transfer the
9490 result to the original descriptor. */
9493 fcncall_realloc_result (gfc_se
*se
, int rank
)
9502 /* Use the allocation done by the library. Substitute the lhs
9503 descriptor with a copy, whose data field is nulled.*/
9504 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9505 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9506 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9508 /* Unallocated, the descriptor does not have a dtype. */
9509 tmp
= gfc_conv_descriptor_dtype (desc
);
9510 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9512 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9513 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9514 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9516 /* Free the lhs after the function call and copy the result data to
9517 the lhs descriptor. */
9518 tmp
= gfc_conv_descriptor_data_get (desc
);
9519 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9520 logical_type_node
, tmp
,
9521 build_int_cst (TREE_TYPE (tmp
), 0));
9522 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9523 tmp
= gfc_call_free (tmp
);
9524 gfc_add_expr_to_block (&se
->post
, tmp
);
9526 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9527 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9529 /* Check that the shapes are the same between lhs and expression. */
9530 for (n
= 0 ; n
< rank
; n
++)
9533 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9534 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9536 gfc_array_index_type
, tmp
, tmp1
);
9537 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9538 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9539 gfc_array_index_type
, tmp
, tmp1
);
9540 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9541 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9542 gfc_array_index_type
, tmp
, tmp1
);
9543 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9544 logical_type_node
, tmp
,
9545 gfc_index_zero_node
);
9546 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9547 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9548 logical_type_node
, tmp
,
9552 /* 'zero_cond' being true is equal to lhs not being allocated or the
9553 shapes being different. */
9554 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9556 /* Now reset the bounds returned from the function call to bounds based
9557 on the lhs lbounds, except where the lhs is not allocated or the shapes
9558 of 'variable and 'expr' are different. Set the offset accordingly. */
9559 offset
= gfc_index_zero_node
;
9560 for (n
= 0 ; n
< rank
; n
++)
9564 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9565 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9566 gfc_array_index_type
, zero_cond
,
9567 gfc_index_one_node
, lbound
);
9568 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9570 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9571 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9572 gfc_array_index_type
, tmp
, lbound
);
9573 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9574 gfc_rank_cst
[n
], lbound
);
9575 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9576 gfc_rank_cst
[n
], tmp
);
9578 /* Set stride and accumulate the offset. */
9579 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9580 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9581 gfc_rank_cst
[n
], tmp
);
9582 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9583 gfc_array_index_type
, lbound
, tmp
);
9584 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9585 gfc_array_index_type
, offset
, tmp
);
9586 offset
= gfc_evaluate_now (offset
, &se
->post
);
9589 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9594 /* Try to translate array(:) = func (...), where func is a transformational
9595 array function, without using a temporary. Returns NULL if this isn't the
9599 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9603 gfc_component
*comp
= NULL
;
9606 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9609 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9611 comp
= gfc_get_proc_ptr_comp (expr2
);
9613 if (!(expr2
->value
.function
.isym
9614 || (comp
&& comp
->attr
.dimension
)
9615 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9616 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
9619 gfc_init_se (&se
, NULL
);
9620 gfc_start_block (&se
.pre
);
9621 se
.want_pointer
= 1;
9623 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9625 if (expr1
->ts
.type
== BT_DERIVED
9626 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9629 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9631 gfc_add_expr_to_block (&se
.pre
, tmp
);
9634 se
.direct_byref
= 1;
9635 se
.ss
= gfc_walk_expr (expr2
);
9636 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9638 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9639 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9640 Clearly, this cannot be done for an allocatable function result, since
9641 the shape of the result is unknown and, in any case, the function must
9642 correctly take care of the reallocation internally. For intrinsic
9643 calls, the array data is freed and the library takes care of allocation.
9644 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9646 if (flag_realloc_lhs
9647 && gfc_is_reallocatable_lhs (expr1
)
9648 && !gfc_expr_attr (expr1
).codimension
9649 && !gfc_is_coindexed (expr1
)
9650 && !(expr2
->value
.function
.esym
9651 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9653 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9655 if (!expr2
->value
.function
.isym
)
9657 ss
= gfc_walk_expr (expr1
);
9658 gcc_assert (ss
!= gfc_ss_terminator
);
9660 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9661 ss
->is_alloc_lhs
= 1;
9664 fcncall_realloc_result (&se
, expr1
->rank
);
9667 gfc_conv_function_expr (&se
, expr2
);
9668 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9671 gfc_cleanup_loop (&loop
);
9673 gfc_free_ss_chain (se
.ss
);
9675 return gfc_finish_block (&se
.pre
);
9679 /* Try to efficiently translate array(:) = 0. Return NULL if this
9683 gfc_trans_zero_assign (gfc_expr
* expr
)
9685 tree dest
, len
, type
;
9689 sym
= expr
->symtree
->n
.sym
;
9690 dest
= gfc_get_symbol_decl (sym
);
9692 type
= TREE_TYPE (dest
);
9693 if (POINTER_TYPE_P (type
))
9694 type
= TREE_TYPE (type
);
9695 if (!GFC_ARRAY_TYPE_P (type
))
9698 /* Determine the length of the array. */
9699 len
= GFC_TYPE_ARRAY_SIZE (type
);
9700 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9703 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9704 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9705 fold_convert (gfc_array_index_type
, tmp
));
9707 /* If we are zeroing a local array avoid taking its address by emitting
9709 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9710 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9711 dest
, build_constructor (TREE_TYPE (dest
),
9714 /* Convert arguments to the correct types. */
9715 dest
= fold_convert (pvoid_type_node
, dest
);
9716 len
= fold_convert (size_type_node
, len
);
9718 /* Construct call to __builtin_memset. */
9719 tmp
= build_call_expr_loc (input_location
,
9720 builtin_decl_explicit (BUILT_IN_MEMSET
),
9721 3, dest
, integer_zero_node
, len
);
9722 return fold_convert (void_type_node
, tmp
);
9726 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9727 that constructs the call to __builtin_memcpy. */
9730 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9734 /* Convert arguments to the correct types. */
9735 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9736 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9738 dst
= fold_convert (pvoid_type_node
, dst
);
9740 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9741 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9743 src
= fold_convert (pvoid_type_node
, src
);
9745 len
= fold_convert (size_type_node
, len
);
9747 /* Construct call to __builtin_memcpy. */
9748 tmp
= build_call_expr_loc (input_location
,
9749 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9751 return fold_convert (void_type_node
, tmp
);
9755 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9756 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9757 source/rhs, both are gfc_full_array_ref_p which have been checked for
9761 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9763 tree dst
, dlen
, dtype
;
9764 tree src
, slen
, stype
;
9767 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9768 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9770 dtype
= TREE_TYPE (dst
);
9771 if (POINTER_TYPE_P (dtype
))
9772 dtype
= TREE_TYPE (dtype
);
9773 stype
= TREE_TYPE (src
);
9774 if (POINTER_TYPE_P (stype
))
9775 stype
= TREE_TYPE (stype
);
9777 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9780 /* Determine the lengths of the arrays. */
9781 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9782 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9784 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9785 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9786 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9788 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9789 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9791 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9792 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9793 slen
, fold_convert (gfc_array_index_type
, tmp
));
9795 /* Sanity check that they are the same. This should always be
9796 the case, as we should already have checked for conformance. */
9797 if (!tree_int_cst_equal (slen
, dlen
))
9800 return gfc_build_memcpy_call (dst
, src
, dlen
);
9804 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9805 this can't be done. EXPR1 is the destination/lhs for which
9806 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9809 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9811 unsigned HOST_WIDE_INT nelem
;
9817 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9821 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9822 dtype
= TREE_TYPE (dst
);
9823 if (POINTER_TYPE_P (dtype
))
9824 dtype
= TREE_TYPE (dtype
);
9825 if (!GFC_ARRAY_TYPE_P (dtype
))
9828 /* Determine the lengths of the array. */
9829 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9830 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9833 /* Confirm that the constructor is the same size. */
9834 if (compare_tree_int (len
, nelem
) != 0)
9837 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9838 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9839 fold_convert (gfc_array_index_type
, tmp
));
9841 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9842 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9844 stype
= TREE_TYPE (src
);
9845 if (POINTER_TYPE_P (stype
))
9846 stype
= TREE_TYPE (stype
);
9848 return gfc_build_memcpy_call (dst
, src
, len
);
9852 /* Tells whether the expression is to be treated as a variable reference. */
9855 gfc_expr_is_variable (gfc_expr
*expr
)
9858 gfc_component
*comp
;
9859 gfc_symbol
*func_ifc
;
9861 if (expr
->expr_type
== EXPR_VARIABLE
)
9864 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9867 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9868 return gfc_expr_is_variable (arg
);
9871 /* A data-pointer-returning function should be considered as a variable
9873 if (expr
->expr_type
== EXPR_FUNCTION
9874 && expr
->ref
== NULL
)
9876 if (expr
->value
.function
.isym
!= NULL
)
9879 if (expr
->value
.function
.esym
!= NULL
)
9881 func_ifc
= expr
->value
.function
.esym
;
9886 gcc_assert (expr
->symtree
);
9887 func_ifc
= expr
->symtree
->n
.sym
;
9894 comp
= gfc_get_proc_ptr_comp (expr
);
9895 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9898 func_ifc
= comp
->ts
.interface
;
9902 if (expr
->expr_type
== EXPR_COMPCALL
)
9904 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9905 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9912 gcc_assert (func_ifc
->attr
.function
9913 && func_ifc
->result
!= NULL
);
9914 return func_ifc
->result
->attr
.pointer
;
9918 /* Is the lhs OK for automatic reallocation? */
9921 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9925 /* An allocatable variable with no reference. */
9926 if (expr
->symtree
->n
.sym
->attr
.allocatable
9930 /* All that can be left are allocatable components. However, we do
9931 not check for allocatable components here because the expression
9932 could be an allocatable component of a pointer component. */
9933 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9934 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9937 /* Find an allocatable component ref last. */
9938 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9939 if (ref
->type
== REF_COMPONENT
9941 && ref
->u
.c
.component
->attr
.allocatable
)
9948 /* Allocate or reallocate scalar lhs, as necessary. */
9951 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9966 if (!expr1
|| expr1
->rank
)
9969 if (!expr2
|| expr2
->rank
)
9972 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9973 if (ref
->type
== REF_SUBSTRING
)
9976 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9978 /* Since this is a scalar lhs, we can afford to do this. That is,
9979 there is no risk of side effects being repeated. */
9980 gfc_init_se (&lse
, NULL
);
9981 lse
.want_pointer
= 1;
9982 gfc_conv_expr (&lse
, expr1
);
9984 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9985 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9987 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9988 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9989 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9991 tmp
= build3_v (COND_EXPR
, cond
,
9992 build1_v (GOTO_EXPR
, jump_label1
),
9993 build_empty_stmt (input_location
));
9994 gfc_add_expr_to_block (block
, tmp
);
9996 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9998 /* Use the rhs string length and the lhs element size. */
9999 size
= string_length
;
10000 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
10001 tmp
= TYPE_SIZE_UNIT (tmp
);
10002 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
10003 TREE_TYPE (tmp
), tmp
,
10004 fold_convert (TREE_TYPE (tmp
), size
));
10008 /* Otherwise use the length in bytes of the rhs. */
10009 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
10010 size_in_bytes
= size
;
10013 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
10014 size_in_bytes
, size_one_node
);
10016 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
10018 tree caf_decl
, token
;
10020 symbol_attribute attr
;
10022 gfc_clear_attr (&attr
);
10023 gfc_init_se (&caf_se
, NULL
);
10025 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
10026 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
10028 gfc_add_block_to_block (block
, &caf_se
.pre
);
10029 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
10030 gfc_build_addr_expr (NULL_TREE
, token
),
10031 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
10034 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10036 tmp
= build_call_expr_loc (input_location
,
10037 builtin_decl_explicit (BUILT_IN_CALLOC
),
10038 2, build_one_cst (size_type_node
),
10040 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10041 gfc_add_modify (block
, lse
.expr
, tmp
);
10045 tmp
= build_call_expr_loc (input_location
,
10046 builtin_decl_explicit (BUILT_IN_MALLOC
),
10048 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10049 gfc_add_modify (block
, lse
.expr
, tmp
);
10052 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10054 /* Deferred characters need checking for lhs and rhs string
10055 length. Other deferred parameter variables will have to
10057 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
10058 gfc_add_expr_to_block (block
, tmp
);
10060 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
10061 gfc_add_expr_to_block (block
, tmp
);
10063 /* For a deferred length character, reallocate if lengths of lhs and
10064 rhs are different. */
10065 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
10067 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10069 fold_convert (TREE_TYPE (lse
.string_length
),
10071 /* Jump past the realloc if the lengths are the same. */
10072 tmp
= build3_v (COND_EXPR
, cond
,
10073 build1_v (GOTO_EXPR
, jump_label2
),
10074 build_empty_stmt (input_location
));
10075 gfc_add_expr_to_block (block
, tmp
);
10076 tmp
= build_call_expr_loc (input_location
,
10077 builtin_decl_explicit (BUILT_IN_REALLOC
),
10078 2, fold_convert (pvoid_type_node
, lse
.expr
),
10080 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
10081 gfc_add_modify (block
, lse
.expr
, tmp
);
10082 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
10083 gfc_add_expr_to_block (block
, tmp
);
10085 /* Update the lhs character length. */
10086 size
= string_length
;
10087 gfc_add_modify (block
, lse
.string_length
,
10088 fold_convert (TREE_TYPE (lse
.string_length
), size
));
10092 /* Check for assignments of the type
10096 to make sure we do not check for reallocation unneccessarily. */
10100 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
10102 gfc_actual_arglist
*a
;
10105 switch (expr2
->expr_type
)
10107 case EXPR_VARIABLE
:
10108 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
10110 case EXPR_FUNCTION
:
10111 if (expr2
->value
.function
.esym
10112 && expr2
->value
.function
.esym
->attr
.elemental
)
10114 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10117 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10122 else if (expr2
->value
.function
.isym
10123 && expr2
->value
.function
.isym
->elemental
)
10125 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
10128 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
10137 switch (expr2
->value
.op
.op
)
10139 case INTRINSIC_NOT
:
10140 case INTRINSIC_UPLUS
:
10141 case INTRINSIC_UMINUS
:
10142 case INTRINSIC_PARENTHESES
:
10143 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
10145 case INTRINSIC_PLUS
:
10146 case INTRINSIC_MINUS
:
10147 case INTRINSIC_TIMES
:
10148 case INTRINSIC_DIVIDE
:
10149 case INTRINSIC_POWER
:
10150 case INTRINSIC_AND
:
10152 case INTRINSIC_EQV
:
10153 case INTRINSIC_NEQV
:
10160 case INTRINSIC_EQ_OS
:
10161 case INTRINSIC_NE_OS
:
10162 case INTRINSIC_GT_OS
:
10163 case INTRINSIC_GE_OS
:
10164 case INTRINSIC_LT_OS
:
10165 case INTRINSIC_LE_OS
:
10167 e1
= expr2
->value
.op
.op1
;
10168 e2
= expr2
->value
.op
.op2
;
10170 if (e1
->rank
== 0 && e2
->rank
> 0)
10171 return is_runtime_conformable (expr1
, e2
);
10172 else if (e1
->rank
> 0 && e2
->rank
== 0)
10173 return is_runtime_conformable (expr1
, e1
);
10174 else if (e1
->rank
> 0 && e2
->rank
> 0)
10175 return is_runtime_conformable (expr1
, e1
)
10176 && is_runtime_conformable (expr1
, e2
);
10194 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
10195 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
10196 bool class_realloc
)
10198 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
10199 vec
<tree
, va_gc
> *args
= NULL
;
10201 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
10204 /* Generate allocation of the lhs. */
10210 tmp
= gfc_vptr_size_get (vptr
);
10211 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10212 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10213 gfc_init_block (&alloc
);
10214 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
10215 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
10216 logical_type_node
, class_han
,
10217 build_int_cst (prvoid_type_node
, 0));
10218 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
10220 PRED_FORTRAN_FAIL_ALLOC
),
10221 gfc_finish_block (&alloc
),
10222 build_empty_stmt (input_location
));
10223 gfc_add_expr_to_block (&lse
->pre
, tmp
);
10226 fcn
= gfc_vptr_copy_get (vptr
);
10228 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
10229 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
10232 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10233 || INDIRECT_REF_P (tmp
)
10234 || (rhs
->ts
.type
== BT_DERIVED
10235 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10236 && !rhs
->ts
.u
.derived
->attr
.pointer
10237 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
10238 || (UNLIMITED_POLY (rhs
)
10239 && !CLASS_DATA (rhs
)->attr
.pointer
10240 && !CLASS_DATA (rhs
)->attr
.allocatable
))
10241 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10243 vec_safe_push (args
, tmp
);
10244 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10245 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10246 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
10247 || INDIRECT_REF_P (tmp
)
10248 || (lhs
->ts
.type
== BT_DERIVED
10249 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
10250 && !lhs
->ts
.u
.derived
->attr
.pointer
10251 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
10252 || (UNLIMITED_POLY (lhs
)
10253 && !CLASS_DATA (lhs
)->attr
.pointer
10254 && !CLASS_DATA (lhs
)->attr
.allocatable
))
10255 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
10257 vec_safe_push (args
, tmp
);
10259 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10261 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10264 vec_safe_push (args
, from_len
);
10265 vec_safe_push (args
, to_len
);
10266 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10268 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10269 logical_type_node
, from_len
,
10270 build_zero_cst (TREE_TYPE (from_len
)));
10271 return fold_build3_loc (input_location
, COND_EXPR
,
10272 void_type_node
, tmp
,
10280 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10281 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10282 stmtblock_t tblock
;
10283 gfc_init_block (&tblock
);
10284 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10285 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10286 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10287 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10288 /* When coming from a ptr_copy lhs and rhs are swapped. */
10289 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10290 fold_convert (TREE_TYPE (rhst
), tmp
));
10291 return gfc_finish_block (&tblock
);
10295 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10296 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10297 init_flag indicates initialization expressions and dealloc that no
10298 deallocate prior assignment is needed (if in doubt, set true).
10299 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10300 routine instead of a pointer assignment. Alias resolution is only done,
10301 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10302 where it is known, that newly allocated memory on the lhs can never be
10303 an alias of the rhs. */
10306 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10307 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10312 gfc_ss
*lss_section
;
10319 bool scalar_to_array
;
10320 tree string_length
;
10322 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10323 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10324 bool is_poly_assign
;
10326 /* Assignment of the form lhs = rhs. */
10327 gfc_start_block (&block
);
10329 gfc_init_se (&lse
, NULL
);
10330 gfc_init_se (&rse
, NULL
);
10332 /* Walk the lhs. */
10333 lss
= gfc_walk_expr (expr1
);
10334 if (gfc_is_reallocatable_lhs (expr1
))
10336 lss
->no_bounds_check
= 1;
10337 if (!(expr2
->expr_type
== EXPR_FUNCTION
10338 && expr2
->value
.function
.isym
!= NULL
10339 && !(expr2
->value
.function
.isym
->elemental
10340 || expr2
->value
.function
.isym
->conversion
)))
10341 lss
->is_alloc_lhs
= 1;
10344 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10348 if ((expr1
->ts
.type
== BT_DERIVED
)
10349 && (gfc_is_class_array_function (expr2
)
10350 || gfc_is_alloc_class_scalar_function (expr2
)))
10351 expr2
->must_finalize
= 1;
10353 /* Checking whether a class assignment is desired is quite complicated and
10354 needed at two locations, so do it once only before the information is
10356 lhs_attr
= gfc_expr_attr (expr1
);
10357 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10358 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10359 && (expr1
->ts
.type
== BT_CLASS
10360 || gfc_is_class_array_ref (expr1
, NULL
)
10361 || gfc_is_class_scalar_expr (expr1
)
10362 || gfc_is_class_array_ref (expr2
, NULL
)
10363 || gfc_is_class_scalar_expr (expr2
));
10366 /* Only analyze the expressions for coarray properties, when in coarray-lib
10368 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10370 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10371 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10374 if (lss
!= gfc_ss_terminator
)
10376 /* The assignment needs scalarization. */
10379 /* Find a non-scalar SS from the lhs. */
10380 while (lss_section
!= gfc_ss_terminator
10381 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10382 lss_section
= lss_section
->next
;
10384 gcc_assert (lss_section
!= gfc_ss_terminator
);
10386 /* Initialize the scalarizer. */
10387 gfc_init_loopinfo (&loop
);
10389 /* Walk the rhs. */
10390 rss
= gfc_walk_expr (expr2
);
10391 if (rss
== gfc_ss_terminator
)
10392 /* The rhs is scalar. Add a ss for the expression. */
10393 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10394 /* When doing a class assign, then the handle to the rhs needs to be a
10395 pointer to allow for polymorphism. */
10396 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10397 rss
->info
->type
= GFC_SS_REFERENCE
;
10399 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10400 /* Associate the SS with the loop. */
10401 gfc_add_ss_to_loop (&loop
, lss
);
10402 gfc_add_ss_to_loop (&loop
, rss
);
10404 /* Calculate the bounds of the scalarization. */
10405 gfc_conv_ss_startstride (&loop
);
10406 /* Enable loop reversal. */
10407 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10408 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10409 /* Resolve any data dependencies in the statement. */
10411 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10412 /* Setup the scalarizing loops. */
10413 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10415 /* Setup the gfc_se structures. */
10416 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10417 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10420 gfc_mark_ss_chain_used (rss
, 1);
10421 if (loop
.temp_ss
== NULL
)
10424 gfc_mark_ss_chain_used (lss
, 1);
10428 lse
.ss
= loop
.temp_ss
;
10429 gfc_mark_ss_chain_used (lss
, 3);
10430 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10433 /* Allow the scalarizer to workshare array assignments. */
10434 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10435 == OMPWS_WORKSHARE_FLAG
10436 && loop
.temp_ss
== NULL
)
10438 maybe_workshare
= true;
10439 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10442 /* Start the scalarized loop body. */
10443 gfc_start_scalarized_body (&loop
, &body
);
10446 gfc_init_block (&body
);
10448 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10450 /* Translate the expression. */
10451 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10452 && lhs_caf_attr
.codimension
;
10453 gfc_conv_expr (&rse
, expr2
);
10455 /* Deal with the case of a scalar class function assigned to a derived type. */
10456 if (gfc_is_alloc_class_scalar_function (expr2
)
10457 && expr1
->ts
.type
== BT_DERIVED
)
10459 rse
.expr
= gfc_class_data_get (rse
.expr
);
10460 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10463 /* Stabilize a string length for temporaries. */
10464 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10465 && !(VAR_P (rse
.string_length
)
10466 || TREE_CODE (rse
.string_length
) == PARM_DECL
10467 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10468 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10469 else if (expr2
->ts
.type
== BT_CHARACTER
)
10471 if (expr1
->ts
.deferred
&& gfc_check_dependency (expr1
, expr2
, true))
10472 rse
.string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10473 string_length
= rse
.string_length
;
10476 string_length
= NULL_TREE
;
10480 gfc_conv_tmp_array_ref (&lse
);
10481 if (expr2
->ts
.type
== BT_CHARACTER
)
10482 lse
.string_length
= string_length
;
10486 gfc_conv_expr (&lse
, expr1
);
10487 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10489 && gfc_expr_attr (expr1
).allocatable
10496 tmp
= INDIRECT_REF_P (lse
.expr
)
10497 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10499 /* We should only get array references here. */
10500 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10501 || TREE_CODE (tmp
) == ARRAY_REF
);
10503 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10504 or the array itself(ARRAY_REF). */
10505 tmp
= TREE_OPERAND (tmp
, 0);
10507 /* Provide the address of the array. */
10508 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10509 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10511 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10512 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10513 msg
= _("Assignment of scalar to unallocated array");
10514 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10515 &expr1
->where
, msg
);
10518 /* Deallocate the lhs parameterized components if required. */
10519 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10520 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10522 if (expr1
->ts
.type
== BT_DERIVED
10523 && expr1
->ts
.u
.derived
10524 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10526 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10528 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10530 else if (expr1
->ts
.type
== BT_CLASS
10531 && CLASS_DATA (expr1
)->ts
.u
.derived
10532 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10534 tmp
= gfc_class_data_get (lse
.expr
);
10535 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10537 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10542 /* Assignments of scalar derived types with allocatable components
10543 to arrays must be done with a deep copy and the rhs temporary
10544 must have its components deallocated afterwards. */
10545 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10546 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10547 && !gfc_expr_is_variable (expr2
)
10548 && expr1
->rank
&& !expr2
->rank
);
10549 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10551 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10552 && gfc_is_alloc_class_scalar_function (expr2
));
10553 if (scalar_to_array
&& dealloc
)
10555 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10556 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10559 /* When assigning a character function result to a deferred-length variable,
10560 the function call must happen before the (re)allocation of the lhs -
10561 otherwise the character length of the result is not known.
10562 NOTE 1: This relies on having the exact dependence of the length type
10563 parameter available to the caller; gfortran saves it in the .mod files.
10564 NOTE 2: Vector array references generate an index temporary that must
10565 not go outside the loop. Otherwise, variables should not generate
10567 NOTE 3: The concatenation operation generates a temporary pointer,
10568 whose allocation must go to the innermost loop.
10569 NOTE 4: Elemental functions may generate a temporary, too. */
10570 if (flag_realloc_lhs
10571 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10572 && !(lss
!= gfc_ss_terminator
10573 && rss
!= gfc_ss_terminator
10574 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
10575 || (expr2
->expr_type
== EXPR_FUNCTION
10576 && expr2
->value
.function
.esym
!= NULL
10577 && expr2
->value
.function
.esym
->attr
.elemental
)
10578 || (expr2
->expr_type
== EXPR_FUNCTION
10579 && expr2
->value
.function
.isym
!= NULL
10580 && expr2
->value
.function
.isym
->elemental
)
10581 || (expr2
->expr_type
== EXPR_OP
10582 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
10583 gfc_add_block_to_block (&block
, &rse
.pre
);
10585 /* Nullify the allocatable components corresponding to those of the lhs
10586 derived type, so that the finalization of the function result does not
10587 affect the lhs of the assignment. Prepend is used to ensure that the
10588 nullification occurs before the call to the finalizer. In the case of
10589 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10590 as part of the deep copy. */
10591 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10592 && (gfc_is_class_array_function (expr2
)
10593 || gfc_is_alloc_class_scalar_function (expr2
)))
10596 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10597 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10598 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10599 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10604 if (is_poly_assign
)
10605 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10606 use_vptr_copy
|| (lhs_attr
.allocatable
10607 && !lhs_attr
.dimension
),
10608 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10609 else if (flag_coarray
== GFC_FCOARRAY_LIB
10610 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10611 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10612 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10614 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10615 allocatable component, because those need to be accessed via the
10616 caf-runtime. No need to check for coindexes here, because resolve
10617 has rewritten those already. */
10619 gfc_actual_arglist a1
, a2
;
10620 /* Clear the structures to prevent accessing garbage. */
10621 memset (&code
, '\0', sizeof (gfc_code
));
10622 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10623 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10628 code
.ext
.actual
= &a1
;
10629 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10630 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10632 else if (!is_poly_assign
&& expr2
->must_finalize
10633 && expr1
->ts
.type
== BT_CLASS
10634 && expr2
->ts
.type
== BT_CLASS
)
10636 /* This case comes about when the scalarizer provides array element
10637 references. Use the vptr copy function, since this does a deep
10638 copy of allocatable components, without which the finalizer call */
10639 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
10640 if (tmp
!= NULL_TREE
)
10642 tree fcn
= gfc_vptr_copy_get (tmp
);
10643 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
10644 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
10645 tmp
= build_call_expr_loc (input_location
,
10647 gfc_build_addr_expr (NULL
, rse
.expr
),
10648 gfc_build_addr_expr (NULL
, lse
.expr
));
10652 /* If nothing else works, do it the old fashioned way! */
10653 if (tmp
== NULL_TREE
)
10654 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10655 gfc_expr_is_variable (expr2
)
10657 || expr2
->expr_type
== EXPR_ARRAY
,
10658 !(l_is_temp
|| init_flag
) && dealloc
,
10659 expr1
->symtree
->n
.sym
->attr
.codimension
);
10661 /* Add the pre blocks to the body. */
10662 gfc_add_block_to_block (&body
, &rse
.pre
);
10663 gfc_add_block_to_block (&body
, &lse
.pre
);
10664 gfc_add_expr_to_block (&body
, tmp
);
10665 /* Add the post blocks to the body. */
10666 gfc_add_block_to_block (&body
, &rse
.post
);
10667 gfc_add_block_to_block (&body
, &lse
.post
);
10669 if (lss
== gfc_ss_terminator
)
10671 /* F2003: Add the code for reallocation on assignment. */
10672 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10673 && !is_poly_assign
)
10674 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10677 /* Use the scalar assignment as is. */
10678 gfc_add_block_to_block (&block
, &body
);
10682 gcc_assert (lse
.ss
== gfc_ss_terminator
10683 && rse
.ss
== gfc_ss_terminator
);
10687 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10689 /* We need to copy the temporary to the actual lhs. */
10690 gfc_init_se (&lse
, NULL
);
10691 gfc_init_se (&rse
, NULL
);
10692 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10693 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10695 rse
.ss
= loop
.temp_ss
;
10698 gfc_conv_tmp_array_ref (&rse
);
10699 gfc_conv_expr (&lse
, expr1
);
10701 gcc_assert (lse
.ss
== gfc_ss_terminator
10702 && rse
.ss
== gfc_ss_terminator
);
10704 if (expr2
->ts
.type
== BT_CHARACTER
)
10705 rse
.string_length
= string_length
;
10707 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10709 gfc_add_expr_to_block (&body
, tmp
);
10712 /* F2003: Allocate or reallocate lhs of allocatable array. */
10713 if (flag_realloc_lhs
10714 && gfc_is_reallocatable_lhs (expr1
)
10716 && !is_runtime_conformable (expr1
, expr2
))
10718 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10719 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10720 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10721 if (tmp
!= NULL_TREE
)
10722 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10725 if (maybe_workshare
)
10726 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10728 /* Generate the copying loops. */
10729 gfc_trans_scalarizing_loops (&loop
, &body
);
10731 /* Wrap the whole thing up. */
10732 gfc_add_block_to_block (&block
, &loop
.pre
);
10733 gfc_add_block_to_block (&block
, &loop
.post
);
10735 gfc_cleanup_loop (&loop
);
10738 return gfc_finish_block (&block
);
10742 /* Check whether EXPR is a copyable array. */
10745 copyable_array_p (gfc_expr
* expr
)
10747 if (expr
->expr_type
!= EXPR_VARIABLE
)
10750 /* First check it's an array. */
10751 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10754 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10757 /* Next check that it's of a simple enough type. */
10758 switch (expr
->ts
.type
)
10770 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10779 /* Translate an assignment. */
10782 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10783 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10787 /* Special case a single function returning an array. */
10788 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10790 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10795 /* Special case assigning an array to zero. */
10796 if (copyable_array_p (expr1
)
10797 && is_zero_initializer_p (expr2
))
10799 tmp
= gfc_trans_zero_assign (expr1
);
10804 /* Special case copying one array to another. */
10805 if (copyable_array_p (expr1
)
10806 && copyable_array_p (expr2
)
10807 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10808 && !gfc_check_dependency (expr1
, expr2
, 0))
10810 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10815 /* Special case initializing an array from a constant array constructor. */
10816 if (copyable_array_p (expr1
)
10817 && expr2
->expr_type
== EXPR_ARRAY
10818 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10820 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10825 if (UNLIMITED_POLY (expr1
) && expr1
->rank
10826 && expr2
->ts
.type
!= BT_CLASS
)
10827 use_vptr_copy
= true;
10829 /* Fallback to the scalarizer to generate explicit loops. */
10830 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10831 use_vptr_copy
, may_alias
);
10835 gfc_trans_init_assign (gfc_code
* code
)
10837 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10841 gfc_trans_assign (gfc_code
* code
)
10843 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);