1 /* Expression translation
2 Copyright (C) 2002-2018 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_expr_to_initialize (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 gfc_add_modify (&parmse
->post
, tmp
,
1136 fold_convert (TREE_TYPE (tmp
), ctree
));
1143 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1144 /* parmse->pre may contain some preparatory instructions for the
1145 temporary array descriptor. Those may only be executed when the
1146 optional argument is set, therefore add parmse->pre's instructions
1147 to block, which is later guarded by an if (optional_arg_given). */
1148 gfc_add_block_to_block (&parmse
->pre
, &block
);
1149 block
.head
= parmse
->pre
.head
;
1150 parmse
->pre
.head
= NULL_TREE
;
1151 tmp
= gfc_finish_block (&block
);
1153 if (optional_alloc_ptr
)
1154 tmp2
= build_empty_stmt (input_location
);
1157 gfc_init_block (&block
);
1159 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1160 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1161 null_pointer_node
));
1162 tmp2
= gfc_finish_block (&block
);
1165 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1167 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1170 gfc_add_block_to_block (&parmse
->pre
, &block
);
1172 /* Pass the address of the class object. */
1173 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1175 if (optional
&& optional_alloc_ptr
)
1176 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1177 TREE_TYPE (parmse
->expr
),
1179 fold_convert (TREE_TYPE (parmse
->expr
),
1180 null_pointer_node
));
1184 /* Given a class array declaration and an index, returns the address
1185 of the referenced element. */
1188 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1191 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1193 data
= data_comp
!= NULL_TREE
? data_comp
:
1194 gfc_class_data_get (class_decl
);
1195 size
= gfc_class_vtab_size_get (class_decl
);
1199 tmp
= fold_convert (gfc_array_index_type
,
1200 gfc_class_len_get (class_decl
));
1201 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1202 gfc_array_index_type
, size
, tmp
);
1203 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1204 logical_type_node
, tmp
,
1205 build_zero_cst (TREE_TYPE (tmp
)));
1206 size
= fold_build3_loc (input_location
, COND_EXPR
,
1207 gfc_array_index_type
, tmp
, ctmp
, size
);
1210 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1211 gfc_array_index_type
,
1214 data
= gfc_conv_descriptor_data_get (data
);
1215 ptr
= fold_convert (pvoid_type_node
, data
);
1216 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1217 return fold_convert (TREE_TYPE (data
), ptr
);
1221 /* Copies one class expression to another, assuming that if either
1222 'to' or 'from' are arrays they are packed. Should 'from' be
1223 NULL_TREE, the initialization expression for 'to' is used, assuming
1224 that the _vptr is set. */
1227 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1237 vec
<tree
, va_gc
> *args
;
1242 bool is_from_desc
= false, is_to_class
= false;
1245 /* To prevent warnings on uninitialized variables. */
1246 from_len
= to_len
= NULL_TREE
;
1248 if (from
!= NULL_TREE
)
1249 fcn
= gfc_class_vtab_copy_get (from
);
1251 fcn
= gfc_class_vtab_copy_get (to
);
1253 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1255 if (from
!= NULL_TREE
)
1257 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1261 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1265 /* Check that from is a class. When the class is part of a coarray,
1266 then from is a common pointer and is to be used as is. */
1267 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1268 ? build_fold_indirect_ref (from
) : from
;
1270 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1271 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1272 ? gfc_class_data_get (from
) : from
;
1273 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1277 from_data
= gfc_class_vtab_def_init_get (to
);
1281 if (from
!= NULL_TREE
&& unlimited
)
1282 from_len
= gfc_class_len_or_zero_get (from
);
1284 from_len
= build_zero_cst (size_type_node
);
1287 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1290 to_data
= gfc_class_data_get (to
);
1292 to_len
= gfc_class_len_get (to
);
1295 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1298 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1300 stmtblock_t loopbody
;
1304 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1306 gfc_init_block (&body
);
1307 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1308 gfc_array_index_type
, nelems
,
1309 gfc_index_one_node
);
1310 nelems
= gfc_evaluate_now (tmp
, &body
);
1311 index
= gfc_create_var (gfc_array_index_type
, "S");
1315 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1317 vec_safe_push (args
, from_ref
);
1320 vec_safe_push (args
, from_data
);
1323 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1326 tmp
= gfc_conv_array_data (to
);
1327 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1328 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1329 gfc_build_array_ref (tmp
, index
, to
));
1331 vec_safe_push (args
, to_ref
);
1333 /* Add bounds check. */
1334 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1337 const char *name
= "<<unknown>>";
1341 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1343 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1344 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1345 logical_type_node
, from_len
, orig_nelems
);
1346 msg
= xasprintf ("Array bound mismatch for dimension %d "
1347 "of array '%s' (%%ld/%%ld)",
1350 gfc_trans_runtime_check (true, false, tmp
, &body
,
1351 &gfc_current_locus
, msg
,
1352 fold_convert (long_integer_type_node
, orig_nelems
),
1353 fold_convert (long_integer_type_node
, from_len
));
1358 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1360 /* Build the body of the loop. */
1361 gfc_init_block (&loopbody
);
1362 gfc_add_expr_to_block (&loopbody
, tmp
);
1364 /* Build the loop and return. */
1365 gfc_init_loopinfo (&loop
);
1367 loop
.from
[0] = gfc_index_zero_node
;
1368 loop
.loopvar
[0] = index
;
1369 loop
.to
[0] = nelems
;
1370 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1371 gfc_init_block (&ifbody
);
1372 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1373 stdcopy
= gfc_finish_block (&ifbody
);
1374 /* In initialization mode from_len is a constant zero. */
1375 if (unlimited
&& !integer_zerop (from_len
))
1377 vec_safe_push (args
, from_len
);
1378 vec_safe_push (args
, to_len
);
1379 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1380 /* Build the body of the loop. */
1381 gfc_init_block (&loopbody
);
1382 gfc_add_expr_to_block (&loopbody
, tmp
);
1384 /* Build the loop and return. */
1385 gfc_init_loopinfo (&loop
);
1387 loop
.from
[0] = gfc_index_zero_node
;
1388 loop
.loopvar
[0] = index
;
1389 loop
.to
[0] = nelems
;
1390 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1391 gfc_init_block (&ifbody
);
1392 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1393 extcopy
= gfc_finish_block (&ifbody
);
1395 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1396 logical_type_node
, from_len
,
1397 build_zero_cst (TREE_TYPE (from_len
)));
1398 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1399 void_type_node
, tmp
, extcopy
, stdcopy
);
1400 gfc_add_expr_to_block (&body
, tmp
);
1401 tmp
= gfc_finish_block (&body
);
1405 gfc_add_expr_to_block (&body
, stdcopy
);
1406 tmp
= gfc_finish_block (&body
);
1408 gfc_cleanup_loop (&loop
);
1412 gcc_assert (!is_from_desc
);
1413 vec_safe_push (args
, from_data
);
1414 vec_safe_push (args
, to_data
);
1415 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1417 /* In initialization mode from_len is a constant zero. */
1418 if (unlimited
&& !integer_zerop (from_len
))
1420 vec_safe_push (args
, from_len
);
1421 vec_safe_push (args
, to_len
);
1422 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1423 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1424 logical_type_node
, from_len
,
1425 build_zero_cst (TREE_TYPE (from_len
)));
1426 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1427 void_type_node
, tmp
, extcopy
, stdcopy
);
1433 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1434 if (from
== NULL_TREE
)
1437 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1439 from_data
, null_pointer_node
);
1440 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1441 void_type_node
, cond
,
1442 tmp
, build_empty_stmt (input_location
));
1450 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1452 gfc_actual_arglist
*actual
;
1457 actual
= gfc_get_actual_arglist ();
1458 actual
->expr
= gfc_copy_expr (rhs
);
1459 actual
->next
= gfc_get_actual_arglist ();
1460 actual
->next
->expr
= gfc_copy_expr (lhs
);
1461 ppc
= gfc_copy_expr (obj
);
1462 gfc_add_vptr_component (ppc
);
1463 gfc_add_component_ref (ppc
, "_copy");
1464 ppc_code
= gfc_get_code (EXEC_CALL
);
1465 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1466 /* Although '_copy' is set to be elemental in class.c, it is
1467 not staying that way. Find out why, sometime.... */
1468 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1469 ppc_code
->ext
.actual
= actual
;
1470 ppc_code
->expr1
= ppc
;
1471 /* Since '_copy' is elemental, the scalarizer will take care
1472 of arrays in gfc_trans_call. */
1473 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1474 gfc_free_statements (ppc_code
);
1476 if (UNLIMITED_POLY(obj
))
1478 /* Check if rhs is non-NULL. */
1480 gfc_init_se (&src
, NULL
);
1481 gfc_conv_expr (&src
, rhs
);
1482 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1483 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1484 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1485 null_pointer_node
));
1486 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1487 build_empty_stmt (input_location
));
1493 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1494 A MEMCPY is needed to copy the full data from the default initializer
1495 of the dynamic type. */
1498 gfc_trans_class_init_assign (gfc_code
*code
)
1502 gfc_se dst
,src
,memsz
;
1503 gfc_expr
*lhs
, *rhs
, *sz
;
1505 gfc_start_block (&block
);
1507 lhs
= gfc_copy_expr (code
->expr1
);
1509 rhs
= gfc_copy_expr (code
->expr1
);
1510 gfc_add_vptr_component (rhs
);
1512 /* Make sure that the component backend_decls have been built, which
1513 will not have happened if the derived types concerned have not
1515 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1516 gfc_add_def_init_component (rhs
);
1517 /* The _def_init is always scalar. */
1520 if (code
->expr1
->ts
.type
== BT_CLASS
1521 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1523 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1524 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1525 /* Adding the array ref to the class expression results in correct
1526 indexing to the dynamic type. */
1527 gfc_add_full_array_ref (lhs
, tmparr
);
1528 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1532 /* Scalar initialization needs the _data component. */
1533 gfc_add_data_component (lhs
);
1534 sz
= gfc_copy_expr (code
->expr1
);
1535 gfc_add_vptr_component (sz
);
1536 gfc_add_size_component (sz
);
1538 gfc_init_se (&dst
, NULL
);
1539 gfc_init_se (&src
, NULL
);
1540 gfc_init_se (&memsz
, NULL
);
1541 gfc_conv_expr (&dst
, lhs
);
1542 gfc_conv_expr (&src
, rhs
);
1543 gfc_conv_expr (&memsz
, sz
);
1544 gfc_add_block_to_block (&block
, &src
.pre
);
1545 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1547 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1549 if (UNLIMITED_POLY(code
->expr1
))
1551 /* Check if _def_init is non-NULL. */
1552 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1553 logical_type_node
, src
.expr
,
1554 fold_convert (TREE_TYPE (src
.expr
),
1555 null_pointer_node
));
1556 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1557 tmp
, build_empty_stmt (input_location
));
1561 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1562 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1564 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1565 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1567 build_empty_stmt (input_location
));
1570 gfc_add_expr_to_block (&block
, tmp
);
1572 return gfc_finish_block (&block
);
1576 /* End of prototype trans-class.c */
1580 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1582 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1583 gfc_warning (OPT_Wrealloc_lhs
,
1584 "Code for reallocating the allocatable array at %L will "
1586 else if (warn_realloc_lhs_all
)
1587 gfc_warning (OPT_Wrealloc_lhs_all
,
1588 "Code for reallocating the allocatable variable at %L "
1589 "will be added", where
);
1593 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1596 /* Copy the scalarization loop variables. */
1599 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1602 dest
->loop
= src
->loop
;
1606 /* Initialize a simple expression holder.
1608 Care must be taken when multiple se are created with the same parent.
1609 The child se must be kept in sync. The easiest way is to delay creation
1610 of a child se until after after the previous se has been translated. */
1613 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1615 memset (se
, 0, sizeof (gfc_se
));
1616 gfc_init_block (&se
->pre
);
1617 gfc_init_block (&se
->post
);
1619 se
->parent
= parent
;
1622 gfc_copy_se_loopvars (se
, parent
);
1626 /* Advances to the next SS in the chain. Use this rather than setting
1627 se->ss = se->ss->next because all the parents needs to be kept in sync.
1631 gfc_advance_se_ss_chain (gfc_se
* se
)
1636 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1639 /* Walk down the parent chain. */
1642 /* Simple consistency check. */
1643 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1644 || p
->parent
->ss
->nested_ss
== p
->ss
);
1646 /* If we were in a nested loop, the next scalarized expression can be
1647 on the parent ss' next pointer. Thus we should not take the next
1648 pointer blindly, but rather go up one nest level as long as next
1649 is the end of chain. */
1651 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1661 /* Ensures the result of the expression as either a temporary variable
1662 or a constant so that it can be used repeatedly. */
1665 gfc_make_safe_expr (gfc_se
* se
)
1669 if (CONSTANT_CLASS_P (se
->expr
))
1672 /* We need a temporary for this result. */
1673 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1674 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1679 /* Return an expression which determines if a dummy parameter is present.
1680 Also used for arguments to procedures with multiple entry points. */
1683 gfc_conv_expr_present (gfc_symbol
* sym
)
1687 gcc_assert (sym
->attr
.dummy
);
1688 decl
= gfc_get_symbol_decl (sym
);
1690 /* Intrinsic scalars with VALUE attribute which are passed by value
1691 use a hidden argument to denote the present status. */
1692 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1693 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1694 && !sym
->attr
.dimension
)
1696 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1699 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1701 strcpy (&name
[1], sym
->name
);
1702 tree_name
= get_identifier (name
);
1704 /* Walk function argument list to find hidden arg. */
1705 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1706 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1707 if (DECL_NAME (cond
) == tree_name
)
1714 if (TREE_CODE (decl
) != PARM_DECL
)
1716 /* Array parameters use a temporary descriptor, we want the real
1718 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1719 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1720 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1723 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1724 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1726 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1727 as actual argument to denote absent dummies. For array descriptors,
1728 we thus also need to check the array descriptor. For BT_CLASS, it
1729 can also occur for scalars and F2003 due to type->class wrapping and
1730 class->class wrapping. Note further that BT_CLASS always uses an
1731 array descriptor for arrays, also for explicit-shape/assumed-size. */
1733 if (!sym
->attr
.allocatable
1734 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1735 || (sym
->ts
.type
== BT_CLASS
1736 && !CLASS_DATA (sym
)->attr
.allocatable
1737 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1738 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1739 || sym
->ts
.type
== BT_CLASS
))
1743 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1744 || sym
->as
->type
== AS_ASSUMED_RANK
1745 || sym
->attr
.codimension
))
1746 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1748 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1749 if (sym
->ts
.type
== BT_CLASS
)
1750 tmp
= gfc_class_data_get (tmp
);
1751 tmp
= gfc_conv_array_data (tmp
);
1753 else if (sym
->ts
.type
== BT_CLASS
)
1754 tmp
= gfc_class_data_get (decl
);
1758 if (tmp
!= NULL_TREE
)
1760 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1761 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1762 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1763 logical_type_node
, cond
, tmp
);
1771 /* Converts a missing, dummy argument into a null or zero. */
1774 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1779 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1783 /* Create a temporary and convert it to the correct type. */
1784 tmp
= gfc_get_int_type (kind
);
1785 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1788 /* Test for a NULL value. */
1789 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1790 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1791 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1792 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1796 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1798 build_zero_cst (TREE_TYPE (se
->expr
)));
1799 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1803 if (ts
.type
== BT_CHARACTER
)
1805 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1806 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1807 present
, se
->string_length
, tmp
);
1808 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1809 se
->string_length
= tmp
;
1815 /* Get the character length of an expression, looking through gfc_refs
1819 gfc_get_expr_charlen (gfc_expr
*e
)
1824 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1825 && e
->ts
.type
== BT_CHARACTER
);
1827 length
= NULL
; /* To silence compiler warning. */
1829 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1832 gfc_init_se (&tmpse
, NULL
);
1833 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1834 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1838 /* First candidate: if the variable is of type CHARACTER, the
1839 expression's length could be the length of the character
1841 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1842 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1844 /* Look through the reference chain for component references. */
1845 for (r
= e
->ref
; r
; r
= r
->next
)
1850 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1851 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1859 /* We should never got substring references here. These will be
1860 broken down by the scalarizer. */
1866 gcc_assert (length
!= NULL
);
1871 /* Return for an expression the backend decl of the coarray. */
1874 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1880 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1882 /* Not-implemented diagnostic. */
1883 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1884 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1885 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1886 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1887 "%L is not supported", &expr
->where
);
1889 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1890 if (ref
->type
== REF_COMPONENT
)
1892 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1893 && UNLIMITED_POLY (ref
->u
.c
.component
)
1894 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1895 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1896 "component at %L is not supported", &expr
->where
);
1899 /* Make sure the backend_decl is present before accessing it. */
1900 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1901 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1902 : expr
->symtree
->n
.sym
->backend_decl
;
1904 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1906 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1908 caf_decl
= gfc_class_data_get (caf_decl
);
1909 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1912 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1914 if (ref
->type
== REF_COMPONENT
1915 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1917 caf_decl
= gfc_class_data_get (caf_decl
);
1918 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1922 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1926 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1929 /* The following code assumes that the coarray is a component reachable via
1930 only scalar components/variables; the Fortran standard guarantees this. */
1932 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1933 if (ref
->type
== REF_COMPONENT
)
1935 gfc_component
*comp
= ref
->u
.c
.component
;
1937 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1938 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1939 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1940 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1941 comp
->backend_decl
, NULL_TREE
);
1942 if (comp
->ts
.type
== BT_CLASS
)
1944 caf_decl
= gfc_class_data_get (caf_decl
);
1945 if (CLASS_DATA (comp
)->attr
.codimension
)
1951 if (comp
->attr
.codimension
)
1957 gcc_assert (found
&& caf_decl
);
1962 /* Obtain the Coarray token - and optionally also the offset. */
1965 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1966 tree se_expr
, gfc_expr
*expr
)
1970 /* Coarray token. */
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1973 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1974 == GFC_ARRAY_ALLOCATABLE
1975 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1976 *token
= gfc_conv_descriptor_token (caf_decl
);
1978 else if (DECL_LANG_SPECIFIC (caf_decl
)
1979 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1980 *token
= GFC_DECL_TOKEN (caf_decl
);
1983 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1984 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1985 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1991 /* Offset between the coarray base address and the address wanted. */
1992 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1993 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1994 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1995 *offset
= build_int_cst (gfc_array_index_type
, 0);
1996 else if (DECL_LANG_SPECIFIC (caf_decl
)
1997 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1998 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1999 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2000 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2002 *offset
= build_int_cst (gfc_array_index_type
, 0);
2004 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2005 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2007 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2008 tmp
= gfc_conv_descriptor_data_get (tmp
);
2010 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2011 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2014 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2018 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2019 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2021 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2022 && expr
->symtree
->n
.sym
->attr
.codimension
2023 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2025 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2026 gfc_ref
*ref
= base_expr
->ref
;
2029 // Iterate through the refs until the last one.
2033 if (ref
->type
== REF_ARRAY
2034 && ref
->u
.ar
.type
!= AR_FULL
)
2036 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2038 for (i
= 0; i
< ranksum
; ++i
)
2040 ref
->u
.ar
.start
[i
] = NULL
;
2041 ref
->u
.ar
.end
[i
] = NULL
;
2043 ref
->u
.ar
.type
= AR_FULL
;
2045 gfc_init_se (&base_se
, NULL
);
2046 if (gfc_caf_attr (base_expr
).dimension
)
2048 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2049 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2053 gfc_conv_expr (&base_se
, base_expr
);
2057 gfc_free_expr (base_expr
);
2058 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2059 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2061 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2062 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2065 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2069 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2070 fold_convert (gfc_array_index_type
, *offset
),
2071 fold_convert (gfc_array_index_type
, tmp
));
2075 /* Convert the coindex of a coarray into an image index; the result is
2076 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2077 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2080 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2083 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2087 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2088 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2090 gcc_assert (ref
!= NULL
);
2092 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2094 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2098 img_idx
= build_zero_cst (gfc_array_index_type
);
2099 extent
= build_one_cst (gfc_array_index_type
);
2100 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2101 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2103 gfc_init_se (&se
, NULL
);
2104 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2105 gfc_add_block_to_block (block
, &se
.pre
);
2106 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2107 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2108 TREE_TYPE (lbound
), se
.expr
, lbound
);
2109 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2111 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2112 TREE_TYPE (tmp
), img_idx
, tmp
);
2113 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2115 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2116 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2117 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2118 TREE_TYPE (tmp
), extent
, tmp
);
2122 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2124 gfc_init_se (&se
, NULL
);
2125 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2126 gfc_add_block_to_block (block
, &se
.pre
);
2127 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2128 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2129 TREE_TYPE (lbound
), se
.expr
, lbound
);
2130 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2132 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2134 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2136 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2137 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2138 TREE_TYPE (ubound
), ubound
, lbound
);
2139 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2140 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2141 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2142 TREE_TYPE (tmp
), extent
, tmp
);
2145 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2146 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2147 return fold_convert (integer_type_node
, img_idx
);
2151 /* For each character array constructor subexpression without a ts.u.cl->length,
2152 replace it by its first element (if there aren't any elements, the length
2153 should already be set to zero). */
2156 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2158 gfc_actual_arglist
* arg
;
2164 switch (e
->expr_type
)
2168 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2169 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2173 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2177 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2178 flatten_array_ctors_without_strlen (arg
->expr
);
2183 /* We've found what we're looking for. */
2184 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2189 gcc_assert (e
->value
.constructor
);
2191 c
= gfc_constructor_first (e
->value
.constructor
);
2195 flatten_array_ctors_without_strlen (new_expr
);
2196 gfc_replace_expr (e
, new_expr
);
2200 /* Otherwise, fall through to handle constructor elements. */
2202 case EXPR_STRUCTURE
:
2203 for (c
= gfc_constructor_first (e
->value
.constructor
);
2204 c
; c
= gfc_constructor_next (c
))
2205 flatten_array_ctors_without_strlen (c
->expr
);
2215 /* Generate code to initialize a string length variable. Returns the
2216 value. For array constructors, cl->length might be NULL and in this case,
2217 the first element of the constructor is needed. expr is the original
2218 expression so we can access it but can be NULL if this is not needed. */
2221 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2225 gfc_init_se (&se
, NULL
);
2227 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2230 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2231 "flatten" array constructors by taking their first element; all elements
2232 should be the same length or a cl->length should be present. */
2235 gfc_expr
* expr_flat
;
2238 expr_flat
= gfc_copy_expr (expr
);
2239 flatten_array_ctors_without_strlen (expr_flat
);
2240 gfc_resolve_expr (expr_flat
);
2242 gfc_conv_expr (&se
, expr_flat
);
2243 gfc_add_block_to_block (pblock
, &se
.pre
);
2244 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2246 gfc_free_expr (expr_flat
);
2250 /* Convert cl->length. */
2252 gcc_assert (cl
->length
);
2254 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2255 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2256 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2257 gfc_add_block_to_block (pblock
, &se
.pre
);
2259 if (cl
->backend_decl
)
2260 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2262 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2267 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2268 const char *name
, locus
*where
)
2278 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2279 type
= build_pointer_type (type
);
2281 gfc_init_se (&start
, se
);
2282 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2283 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2285 if (integer_onep (start
.expr
))
2286 gfc_conv_string_parameter (se
);
2291 /* Avoid multiple evaluation of substring start. */
2292 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2293 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2295 /* Change the start of the string. */
2296 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2299 tmp
= build_fold_indirect_ref_loc (input_location
,
2301 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2302 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2305 /* Length = end + 1 - start. */
2306 gfc_init_se (&end
, se
);
2307 if (ref
->u
.ss
.end
== NULL
)
2308 end
.expr
= se
->string_length
;
2311 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2312 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2316 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2317 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2319 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2321 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2322 logical_type_node
, start
.expr
,
2325 /* Check lower bound. */
2326 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2328 build_one_cst (TREE_TYPE (start
.expr
)));
2329 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2330 logical_type_node
, nonempty
, fault
);
2332 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2333 "is less than one", name
);
2335 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2336 "is less than one");
2337 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2338 fold_convert (long_integer_type_node
,
2342 /* Check upper bound. */
2343 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2344 end
.expr
, se
->string_length
);
2345 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2346 logical_type_node
, nonempty
, fault
);
2348 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2349 "exceeds string length (%%ld)", name
);
2351 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2352 "exceeds string length (%%ld)");
2353 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2354 fold_convert (long_integer_type_node
, end
.expr
),
2355 fold_convert (long_integer_type_node
,
2356 se
->string_length
));
2360 /* Try to calculate the length from the start and end expressions. */
2362 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2364 HOST_WIDE_INT i_len
;
2366 i_len
= gfc_mpz_get_hwi (length
) + 1;
2370 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2371 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2376 fold_convert (gfc_charlen_type_node
, end
.expr
),
2377 fold_convert (gfc_charlen_type_node
, start
.expr
));
2378 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2379 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2380 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2381 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2384 se
->string_length
= tmp
;
2388 /* Convert a derived type component reference. */
2391 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2399 c
= ref
->u
.c
.component
;
2401 if (c
->backend_decl
== NULL_TREE
2402 && ref
->u
.c
.sym
!= NULL
)
2403 gfc_get_derived_type (ref
->u
.c
.sym
);
2405 field
= c
->backend_decl
;
2406 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2408 context
= DECL_FIELD_CONTEXT (field
);
2410 /* Components can correspond to fields of different containing
2411 types, as components are created without context, whereas
2412 a concrete use of a component has the type of decl as context.
2413 So, if the type doesn't match, we search the corresponding
2414 FIELD_DECL in the parent type. To not waste too much time
2415 we cache this result in norestrict_decl.
2416 On the other hand, if the context is a UNION or a MAP (a
2417 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2419 if (context
!= TREE_TYPE (decl
)
2420 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2421 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2423 tree f2
= c
->norestrict_decl
;
2424 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2425 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2426 if (TREE_CODE (f2
) == FIELD_DECL
2427 && DECL_NAME (f2
) == DECL_NAME (field
))
2430 c
->norestrict_decl
= f2
;
2434 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2435 && strcmp ("_data", c
->name
) == 0)
2437 /* Found a ref to the _data component. Store the associated ref to
2438 the vptr in se->class_vptr. */
2439 se
->class_vptr
= gfc_class_vptr_get (decl
);
2442 se
->class_vptr
= NULL_TREE
;
2444 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2445 decl
, field
, NULL_TREE
);
2449 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2450 strlen () conditional below. */
2451 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2452 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2453 && !c
->attr
.pdt_string
)
2455 tmp
= c
->ts
.u
.cl
->backend_decl
;
2456 /* Components must always be constant length. */
2457 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2458 se
->string_length
= tmp
;
2461 if (gfc_deferred_strlen (c
, &field
))
2463 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2465 decl
, field
, NULL_TREE
);
2466 se
->string_length
= tmp
;
2469 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2470 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2471 && c
->ts
.type
!= BT_CHARACTER
)
2472 || c
->attr
.proc_pointer
)
2473 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2478 /* This function deals with component references to components of the
2479 parent type for derived type extensions. */
2481 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2489 c
= ref
->u
.c
.component
;
2491 /* Return if the component is in the parent type. */
2492 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2493 if (strcmp (c
->name
, cmp
->name
) == 0)
2496 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2497 parent
.type
= REF_COMPONENT
;
2499 parent
.u
.c
.sym
= dt
;
2500 parent
.u
.c
.component
= dt
->components
;
2502 if (dt
->backend_decl
== NULL
)
2503 gfc_get_derived_type (dt
);
2505 /* Build the reference and call self. */
2506 gfc_conv_component_ref (se
, &parent
);
2507 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2508 parent
.u
.c
.component
= c
;
2509 conv_parent_component_references (se
, &parent
);
2512 /* Return the contents of a variable. Also handles reference/pointer
2513 variables (all Fortran pointer references are implicit). */
2516 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2521 tree parent_decl
= NULL_TREE
;
2524 bool alternate_entry
;
2527 bool first_time
= true;
2529 sym
= expr
->symtree
->n
.sym
;
2530 is_classarray
= IS_CLASS_ARRAY (sym
);
2534 gfc_ss_info
*ss_info
= ss
->info
;
2536 /* Check that something hasn't gone horribly wrong. */
2537 gcc_assert (ss
!= gfc_ss_terminator
);
2538 gcc_assert (ss_info
->expr
== expr
);
2540 /* A scalarized term. We already know the descriptor. */
2541 se
->expr
= ss_info
->data
.array
.descriptor
;
2542 se
->string_length
= ss_info
->string_length
;
2543 ref
= ss_info
->data
.array
.ref
;
2545 gcc_assert (ref
->type
== REF_ARRAY
2546 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2548 gfc_conv_tmp_array_ref (se
);
2552 tree se_expr
= NULL_TREE
;
2554 se
->expr
= gfc_get_symbol_decl (sym
);
2556 /* Deal with references to a parent results or entries by storing
2557 the current_function_decl and moving to the parent_decl. */
2558 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2559 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2560 && sym
->result
== sym
;
2561 entry_master
= sym
->attr
.result
2562 && sym
->ns
->proc_name
->attr
.entry_master
2563 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2564 if (current_function_decl
)
2565 parent_decl
= DECL_CONTEXT (current_function_decl
);
2567 if ((se
->expr
== parent_decl
&& return_value
)
2568 || (sym
->ns
&& sym
->ns
->proc_name
2570 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2571 && (alternate_entry
|| entry_master
)))
2576 /* Special case for assigning the return value of a function.
2577 Self recursive functions must have an explicit return value. */
2578 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2579 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2581 /* Similarly for alternate entry points. */
2582 else if (alternate_entry
2583 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2586 gfc_entry_list
*el
= NULL
;
2588 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2591 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2596 else if (entry_master
2597 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2599 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2604 /* Procedure actual arguments. Look out for temporary variables
2605 with the same attributes as function values. */
2606 else if (!sym
->attr
.temporary
2607 && sym
->attr
.flavor
== FL_PROCEDURE
2608 && se
->expr
!= current_function_decl
)
2610 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2612 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2613 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2619 /* Dereference the expression, where needed. Since characters
2620 are entirely different from other types, they are treated
2622 if (sym
->ts
.type
== BT_CHARACTER
)
2624 /* Dereference character pointer dummy arguments
2626 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2628 || sym
->attr
.function
2629 || sym
->attr
.result
))
2630 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2634 else if (!sym
->attr
.value
)
2636 /* Dereference temporaries for class array dummy arguments. */
2637 if (sym
->attr
.dummy
&& is_classarray
2638 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2640 if (!se
->descriptor_only
)
2641 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2643 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2647 /* Dereference non-character scalar dummy arguments. */
2648 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2649 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2650 && (sym
->ts
.type
!= BT_CLASS
2651 || (!CLASS_DATA (sym
)->attr
.dimension
2652 && !(CLASS_DATA (sym
)->attr
.codimension
2653 && CLASS_DATA (sym
)->attr
.allocatable
))))
2654 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2657 /* Dereference scalar hidden result. */
2658 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2659 && (sym
->attr
.function
|| sym
->attr
.result
)
2660 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2661 && !sym
->attr
.always_explicit
)
2662 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2665 /* Dereference non-character, non-class pointer variables.
2666 These must be dummies, results, or scalars. */
2668 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2669 || gfc_is_associate_pointer (sym
)
2670 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2672 || sym
->attr
.function
2674 || (!sym
->attr
.dimension
2675 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2676 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2678 /* Now treat the class array pointer variables accordingly. */
2679 else if (sym
->ts
.type
== BT_CLASS
2681 && (CLASS_DATA (sym
)->attr
.dimension
2682 || CLASS_DATA (sym
)->attr
.codimension
)
2683 && ((CLASS_DATA (sym
)->as
2684 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2685 || CLASS_DATA (sym
)->attr
.allocatable
2686 || CLASS_DATA (sym
)->attr
.class_pointer
))
2687 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2689 /* And the case where a non-dummy, non-result, non-function,
2690 non-allotable and non-pointer classarray is present. This case was
2691 previously covered by the first if, but with introducing the
2692 condition !is_classarray there, that case has to be covered
2694 else if (sym
->ts
.type
== BT_CLASS
2696 && !sym
->attr
.function
2697 && !sym
->attr
.result
2698 && (CLASS_DATA (sym
)->attr
.dimension
2699 || CLASS_DATA (sym
)->attr
.codimension
)
2701 || !CLASS_DATA (sym
)->attr
.allocatable
)
2702 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2703 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2710 /* For character variables, also get the length. */
2711 if (sym
->ts
.type
== BT_CHARACTER
)
2713 /* If the character length of an entry isn't set, get the length from
2714 the master function instead. */
2715 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2716 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2718 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2719 gcc_assert (se
->string_length
);
2727 /* Return the descriptor if that's what we want and this is an array
2728 section reference. */
2729 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2731 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2732 /* Return the descriptor for array pointers and allocations. */
2733 if (se
->want_pointer
2734 && ref
->next
== NULL
&& (se
->descriptor_only
))
2737 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2738 /* Return a pointer to an element. */
2742 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2743 && se
->descriptor_only
2744 && !CLASS_DATA (sym
)->attr
.allocatable
2745 && !CLASS_DATA (sym
)->attr
.class_pointer
2746 && CLASS_DATA (sym
)->as
2747 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2748 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2749 /* Skip the first ref of a _data component, because for class
2750 arrays that one is already done by introducing a temporary
2751 array descriptor. */
2754 if (ref
->u
.c
.sym
->attr
.extension
)
2755 conv_parent_component_references (se
, ref
);
2757 gfc_conv_component_ref (se
, ref
);
2758 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2759 && se
->want_pointer
&& se
->descriptor_only
)
2765 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2766 expr
->symtree
->name
, &expr
->where
);
2776 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2778 if (se
->want_pointer
)
2780 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2781 gfc_conv_string_parameter (se
);
2783 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2788 /* Unary ops are easy... Or they would be if ! was a valid op. */
2791 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2796 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2797 /* Initialize the operand. */
2798 gfc_init_se (&operand
, se
);
2799 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2800 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2802 type
= gfc_typenode_for_spec (&expr
->ts
);
2804 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2805 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2806 All other unary operators have an equivalent GIMPLE unary operator. */
2807 if (code
== TRUTH_NOT_EXPR
)
2808 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2809 build_int_cst (type
, 0));
2811 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2815 /* Expand power operator to optimal multiplications when a value is raised
2816 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2817 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2818 Programming", 3rd Edition, 1998. */
2820 /* This code is mostly duplicated from expand_powi in the backend.
2821 We establish the "optimal power tree" lookup table with the defined size.
2822 The items in the table are the exponents used to calculate the index
2823 exponents. Any integer n less than the value can get an "addition chain",
2824 with the first node being one. */
2825 #define POWI_TABLE_SIZE 256
2827 /* The table is from builtins.c. */
2828 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2830 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2831 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2832 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2833 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2834 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2835 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2836 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2837 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2838 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2839 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2840 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2841 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2842 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2843 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2844 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2845 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2846 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2847 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2848 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2849 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2850 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2851 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2852 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2853 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2854 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2855 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2856 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2857 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2858 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2859 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2860 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2861 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2864 /* If n is larger than lookup table's max index, we use the "window
2866 #define POWI_WINDOW_SIZE 3
2868 /* Recursive function to expand the power operator. The temporary
2869 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2871 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2878 if (n
< POWI_TABLE_SIZE
)
2883 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2884 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2888 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2889 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2890 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2894 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2898 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2899 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2901 if (n
< POWI_TABLE_SIZE
)
2908 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2909 return 1. Else return 0 and a call to runtime library functions
2910 will have to be built. */
2912 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2917 tree vartmp
[POWI_TABLE_SIZE
];
2919 unsigned HOST_WIDE_INT n
;
2921 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2923 /* If exponent is too large, we won't expand it anyway, so don't bother
2924 with large integer values. */
2925 if (!wi::fits_shwi_p (wrhs
))
2928 m
= wrhs
.to_shwi ();
2929 /* Use the wide_int's routine to reliably get the absolute value on all
2930 platforms. Then convert it to a HOST_WIDE_INT like above. */
2931 n
= wi::abs (wrhs
).to_shwi ();
2933 type
= TREE_TYPE (lhs
);
2934 sgn
= tree_int_cst_sgn (rhs
);
2936 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2937 || optimize_size
) && (m
> 2 || m
< -1))
2943 se
->expr
= gfc_build_const (type
, integer_one_node
);
2947 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2948 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2950 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2951 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2952 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2953 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2956 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2959 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2960 logical_type_node
, tmp
, cond
);
2961 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2962 tmp
, build_int_cst (type
, 1),
2963 build_int_cst (type
, 0));
2967 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2968 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2969 build_int_cst (type
, -1),
2970 build_int_cst (type
, 0));
2971 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2972 cond
, build_int_cst (type
, 1), tmp
);
2976 memset (vartmp
, 0, sizeof (vartmp
));
2980 tmp
= gfc_build_const (type
, integer_one_node
);
2981 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2985 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2991 /* Power op (**). Constant integer exponent has special handling. */
2994 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2996 tree gfc_int4_type_node
;
2999 int res_ikind_1
, res_ikind_2
;
3004 gfc_init_se (&lse
, se
);
3005 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3006 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3007 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3009 gfc_init_se (&rse
, se
);
3010 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3011 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3013 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3014 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3015 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3018 gfc_int4_type_node
= gfc_get_int_type (4);
3020 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3021 library routine. But in the end, we have to convert the result back
3022 if this case applies -- with res_ikind_K, we keep track whether operand K
3023 falls into this case. */
3027 kind
= expr
->value
.op
.op1
->ts
.kind
;
3028 switch (expr
->value
.op
.op2
->ts
.type
)
3031 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3036 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3037 res_ikind_2
= ikind
;
3059 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3061 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3088 switch (expr
->value
.op
.op1
->ts
.type
)
3091 if (kind
== 3) /* Case 16 was not handled properly above. */
3093 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3097 /* Use builtins for real ** int4. */
3103 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3107 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3111 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3115 /* Use the __builtin_powil() only if real(kind=16) is
3116 actually the C long double type. */
3117 if (!gfc_real16_is_float128
)
3118 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3126 /* If we don't have a good builtin for this, go for the
3127 library function. */
3129 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3133 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3142 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3146 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3154 se
->expr
= build_call_expr_loc (input_location
,
3155 fndecl
, 2, lse
.expr
, rse
.expr
);
3157 /* Convert the result back if it is of wrong integer kind. */
3158 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3160 /* We want the maximum of both operand kinds as result. */
3161 if (res_ikind_1
< res_ikind_2
)
3162 res_ikind_1
= res_ikind_2
;
3163 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3168 /* Generate code to allocate a string temporary. */
3171 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3176 if (gfc_can_put_var_on_stack (len
))
3178 /* Create a temporary variable to hold the result. */
3179 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3180 TREE_TYPE (len
), len
,
3181 build_int_cst (TREE_TYPE (len
), 1));
3182 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3184 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3185 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3187 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3189 var
= gfc_create_var (tmp
, "str");
3190 var
= gfc_build_addr_expr (type
, var
);
3194 /* Allocate a temporary to hold the result. */
3195 var
= gfc_create_var (type
, "pstr");
3196 gcc_assert (POINTER_TYPE_P (type
));
3197 tmp
= TREE_TYPE (type
);
3198 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3199 tmp
= TREE_TYPE (tmp
);
3200 tmp
= TYPE_SIZE_UNIT (tmp
);
3201 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3202 fold_convert (size_type_node
, len
),
3203 fold_convert (size_type_node
, tmp
));
3204 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3205 gfc_add_modify (&se
->pre
, var
, tmp
);
3207 /* Free the temporary afterwards. */
3208 tmp
= gfc_call_free (var
);
3209 gfc_add_expr_to_block (&se
->post
, tmp
);
3216 /* Handle a string concatenation operation. A temporary will be allocated to
3220 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3223 tree len
, type
, var
, tmp
, fndecl
;
3225 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3226 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3227 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3229 gfc_init_se (&lse
, se
);
3230 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3231 gfc_conv_string_parameter (&lse
);
3232 gfc_init_se (&rse
, se
);
3233 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3234 gfc_conv_string_parameter (&rse
);
3236 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3237 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3239 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3240 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3241 if (len
== NULL_TREE
)
3243 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3244 gfc_charlen_type_node
,
3245 fold_convert (gfc_charlen_type_node
,
3247 fold_convert (gfc_charlen_type_node
,
3248 rse
.string_length
));
3251 type
= build_pointer_type (type
);
3253 var
= gfc_conv_string_tmp (se
, type
, len
);
3255 /* Do the actual concatenation. */
3256 if (expr
->ts
.kind
== 1)
3257 fndecl
= gfor_fndecl_concat_string
;
3258 else if (expr
->ts
.kind
== 4)
3259 fndecl
= gfor_fndecl_concat_string_char4
;
3263 tmp
= build_call_expr_loc (input_location
,
3264 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3265 rse
.string_length
, rse
.expr
);
3266 gfc_add_expr_to_block (&se
->pre
, tmp
);
3268 /* Add the cleanup for the operands. */
3269 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3270 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3273 se
->string_length
= len
;
3276 /* Translates an op expression. Common (binary) cases are handled by this
3277 function, others are passed on. Recursion is used in either case.
3278 We use the fact that (op1.ts == op2.ts) (except for the power
3280 Operators need no special handling for scalarized expressions as long as
3281 they call gfc_conv_simple_val to get their operands.
3282 Character strings get special handling. */
3285 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3287 enum tree_code code
;
3296 switch (expr
->value
.op
.op
)
3298 case INTRINSIC_PARENTHESES
:
3299 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3300 && flag_protect_parens
)
3302 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3303 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3308 case INTRINSIC_UPLUS
:
3309 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3312 case INTRINSIC_UMINUS
:
3313 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3317 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3320 case INTRINSIC_PLUS
:
3324 case INTRINSIC_MINUS
:
3328 case INTRINSIC_TIMES
:
3332 case INTRINSIC_DIVIDE
:
3333 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3334 an integer, we must round towards zero, so we use a
3336 if (expr
->ts
.type
== BT_INTEGER
)
3337 code
= TRUNC_DIV_EXPR
;
3342 case INTRINSIC_POWER
:
3343 gfc_conv_power_op (se
, expr
);
3346 case INTRINSIC_CONCAT
:
3347 gfc_conv_concat_op (se
, expr
);
3351 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3356 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3360 /* EQV and NEQV only work on logicals, but since we represent them
3361 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3363 case INTRINSIC_EQ_OS
:
3371 case INTRINSIC_NE_OS
:
3372 case INTRINSIC_NEQV
:
3379 case INTRINSIC_GT_OS
:
3386 case INTRINSIC_GE_OS
:
3393 case INTRINSIC_LT_OS
:
3400 case INTRINSIC_LE_OS
:
3406 case INTRINSIC_USER
:
3407 case INTRINSIC_ASSIGN
:
3408 /* These should be converted into function calls by the frontend. */
3412 fatal_error (input_location
, "Unknown intrinsic op");
3416 /* The only exception to this is **, which is handled separately anyway. */
3417 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3419 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3423 gfc_init_se (&lse
, se
);
3424 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3425 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3428 gfc_init_se (&rse
, se
);
3429 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3430 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3434 gfc_conv_string_parameter (&lse
);
3435 gfc_conv_string_parameter (&rse
);
3437 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3438 rse
.string_length
, rse
.expr
,
3439 expr
->value
.op
.op1
->ts
.kind
,
3441 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3442 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3445 type
= gfc_typenode_for_spec (&expr
->ts
);
3449 /* The result of logical ops is always logical_type_node. */
3450 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3451 lse
.expr
, rse
.expr
);
3452 se
->expr
= convert (type
, tmp
);
3455 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3457 /* Add the post blocks. */
3458 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3459 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3462 /* If a string's length is one, we convert it to a single character. */
3465 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3469 || !tree_fits_uhwi_p (len
)
3470 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3473 if (TREE_INT_CST_LOW (len
) == 1)
3475 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3476 return build_fold_indirect_ref_loc (input_location
, str
);
3480 && TREE_CODE (str
) == ADDR_EXPR
3481 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3482 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3483 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3484 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3485 && TREE_INT_CST_LOW (len
) > 1
3486 && TREE_INT_CST_LOW (len
)
3487 == (unsigned HOST_WIDE_INT
)
3488 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3490 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3491 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3492 if (TREE_CODE (ret
) == INTEGER_CST
)
3494 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3495 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3496 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3498 for (i
= 1; i
< length
; i
++)
3511 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3514 if (sym
->backend_decl
)
3516 /* This becomes the nominal_type in
3517 function.c:assign_parm_find_data_types. */
3518 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3519 /* This becomes the passed_type in
3520 function.c:assign_parm_find_data_types. C promotes char to
3521 integer for argument passing. */
3522 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3524 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3529 /* If we have a constant character expression, make it into an
3531 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3536 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3537 (int)(*expr
)->value
.character
.string
[0]);
3538 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3540 /* The expr needs to be compatible with a C int. If the
3541 conversion fails, then the 2 causes an ICE. */
3542 ts
.type
= BT_INTEGER
;
3543 ts
.kind
= gfc_c_int_kind
;
3544 gfc_convert_type (*expr
, &ts
, 2);
3547 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3549 if ((*expr
)->ref
== NULL
)
3551 se
->expr
= gfc_string_to_single_character
3552 (build_int_cst (integer_type_node
, 1),
3553 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3555 ((*expr
)->symtree
->n
.sym
)),
3560 gfc_conv_variable (se
, *expr
);
3561 se
->expr
= gfc_string_to_single_character
3562 (build_int_cst (integer_type_node
, 1),
3563 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3571 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3572 if STR is a string literal, otherwise return -1. */
3575 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3578 && TREE_CODE (str
) == ADDR_EXPR
3579 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3580 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3581 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3582 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3583 && tree_fits_uhwi_p (len
)
3584 && tree_to_uhwi (len
) >= 1
3585 && tree_to_uhwi (len
)
3586 == (unsigned HOST_WIDE_INT
)
3587 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3589 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3590 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3591 if (TREE_CODE (folded
) == INTEGER_CST
)
3593 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3594 int length
= TREE_STRING_LENGTH (string_cst
);
3595 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3597 for (; length
> 0; length
--)
3598 if (ptr
[length
- 1] != ' ')
3607 /* Helper to build a call to memcmp. */
3610 build_memcmp_call (tree s1
, tree s2
, tree n
)
3614 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3615 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3617 s1
= fold_convert (pvoid_type_node
, s1
);
3619 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3620 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3622 s2
= fold_convert (pvoid_type_node
, s2
);
3624 n
= fold_convert (size_type_node
, n
);
3626 tmp
= build_call_expr_loc (input_location
,
3627 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3630 return fold_convert (integer_type_node
, tmp
);
3633 /* Compare two strings. If they are all single characters, the result is the
3634 subtraction of them. Otherwise, we build a library call. */
3637 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3638 enum tree_code code
)
3644 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3645 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3647 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3648 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3650 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3652 /* Deal with single character specially. */
3653 sc1
= fold_convert (integer_type_node
, sc1
);
3654 sc2
= fold_convert (integer_type_node
, sc2
);
3655 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3659 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3661 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3663 /* If one string is a string literal with LEN_TRIM longer
3664 than the length of the second string, the strings
3666 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3667 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3668 return integer_one_node
;
3669 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3670 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3671 return integer_one_node
;
3674 /* We can compare via memcpy if the strings are known to be equal
3675 in length and they are
3677 - kind=4 and the comparison is for (in)equality. */
3679 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3680 && tree_int_cst_equal (len1
, len2
)
3681 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3686 chartype
= gfc_get_char_type (kind
);
3687 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3688 fold_convert (TREE_TYPE(len1
),
3689 TYPE_SIZE_UNIT(chartype
)),
3691 return build_memcmp_call (str1
, str2
, tmp
);
3694 /* Build a call for the comparison. */
3696 fndecl
= gfor_fndecl_compare_string
;
3698 fndecl
= gfor_fndecl_compare_string_char4
;
3702 return build_call_expr_loc (input_location
, fndecl
, 4,
3703 len1
, str1
, len2
, str2
);
3707 /* Return the backend_decl for a procedure pointer component. */
3710 get_proc_ptr_comp (gfc_expr
*e
)
3716 gfc_init_se (&comp_se
, NULL
);
3717 e2
= gfc_copy_expr (e
);
3718 /* We have to restore the expr type later so that gfc_free_expr frees
3719 the exact same thing that was allocated.
3720 TODO: This is ugly. */
3721 old_type
= e2
->expr_type
;
3722 e2
->expr_type
= EXPR_VARIABLE
;
3723 gfc_conv_expr (&comp_se
, e2
);
3724 e2
->expr_type
= old_type
;
3726 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3730 /* Convert a typebound function reference from a class object. */
3732 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3737 if (!VAR_P (base_object
))
3739 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3740 gfc_add_modify (&se
->pre
, var
, base_object
);
3742 se
->expr
= gfc_class_vptr_get (base_object
);
3743 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3745 while (ref
&& ref
->next
)
3747 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3748 if (ref
->u
.c
.sym
->attr
.extension
)
3749 conv_parent_component_references (se
, ref
);
3750 gfc_conv_component_ref (se
, ref
);
3751 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3756 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3760 if (gfc_is_proc_ptr_comp (expr
))
3761 tmp
= get_proc_ptr_comp (expr
);
3762 else if (sym
->attr
.dummy
)
3764 tmp
= gfc_get_symbol_decl (sym
);
3765 if (sym
->attr
.proc_pointer
)
3766 tmp
= build_fold_indirect_ref_loc (input_location
,
3768 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3769 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3773 if (!sym
->backend_decl
)
3774 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3776 TREE_USED (sym
->backend_decl
) = 1;
3778 tmp
= sym
->backend_decl
;
3780 if (sym
->attr
.cray_pointee
)
3782 /* TODO - make the cray pointee a pointer to a procedure,
3783 assign the pointer to it and use it for the call. This
3785 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3786 gfc_get_symbol_decl (sym
->cp_pointer
));
3787 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3790 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3792 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3793 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3800 /* Initialize MAPPING. */
3803 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3805 mapping
->syms
= NULL
;
3806 mapping
->charlens
= NULL
;
3810 /* Free all memory held by MAPPING (but not MAPPING itself). */
3813 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3815 gfc_interface_sym_mapping
*sym
;
3816 gfc_interface_sym_mapping
*nextsym
;
3818 gfc_charlen
*nextcl
;
3820 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3822 nextsym
= sym
->next
;
3823 sym
->new_sym
->n
.sym
->formal
= NULL
;
3824 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3825 gfc_free_expr (sym
->expr
);
3826 free (sym
->new_sym
);
3829 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3832 gfc_free_expr (cl
->length
);
3838 /* Return a copy of gfc_charlen CL. Add the returned structure to
3839 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3841 static gfc_charlen
*
3842 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3845 gfc_charlen
*new_charlen
;
3847 new_charlen
= gfc_get_charlen ();
3848 new_charlen
->next
= mapping
->charlens
;
3849 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3851 mapping
->charlens
= new_charlen
;
3856 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3857 array variable that can be used as the actual argument for dummy
3858 argument SYM. Add any initialization code to BLOCK. PACKED is as
3859 for gfc_get_nodesc_array_type and DATA points to the first element
3860 in the passed array. */
3863 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3864 gfc_packed packed
, tree data
)
3869 type
= gfc_typenode_for_spec (&sym
->ts
);
3870 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3871 !sym
->attr
.target
&& !sym
->attr
.pointer
3872 && !sym
->attr
.proc_pointer
);
3874 var
= gfc_create_var (type
, "ifm");
3875 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3881 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3882 and offset of descriptorless array type TYPE given that it has the same
3883 size as DESC. Add any set-up code to BLOCK. */
3886 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3893 offset
= gfc_index_zero_node
;
3894 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3896 dim
= gfc_rank_cst
[n
];
3897 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3898 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3900 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3901 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3902 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3903 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3905 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3907 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3908 gfc_array_index_type
,
3909 gfc_conv_descriptor_ubound_get (desc
, dim
),
3910 gfc_conv_descriptor_lbound_get (desc
, dim
));
3911 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3912 gfc_array_index_type
,
3913 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3914 tmp
= gfc_evaluate_now (tmp
, block
);
3915 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3917 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3918 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3919 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3920 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3921 gfc_array_index_type
, offset
, tmp
);
3923 offset
= gfc_evaluate_now (offset
, block
);
3924 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3928 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3929 in SE. The caller may still use se->expr and se->string_length after
3930 calling this function. */
3933 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3934 gfc_symbol
* sym
, gfc_se
* se
,
3937 gfc_interface_sym_mapping
*sm
;
3941 gfc_symbol
*new_sym
;
3943 gfc_symtree
*new_symtree
;
3945 /* Create a new symbol to represent the actual argument. */
3946 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3947 new_sym
->ts
= sym
->ts
;
3948 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3949 new_sym
->attr
.referenced
= 1;
3950 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3951 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3952 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3953 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3954 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3955 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3956 new_sym
->attr
.function
= sym
->attr
.function
;
3958 /* Ensure that the interface is available and that
3959 descriptors are passed for array actual arguments. */
3960 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3962 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3963 new_sym
->attr
.always_explicit
3964 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3967 /* Create a fake symtree for it. */
3969 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3970 new_symtree
->n
.sym
= new_sym
;
3971 gcc_assert (new_symtree
== root
);
3973 /* Create a dummy->actual mapping. */
3974 sm
= XCNEW (gfc_interface_sym_mapping
);
3975 sm
->next
= mapping
->syms
;
3977 sm
->new_sym
= new_symtree
;
3978 sm
->expr
= gfc_copy_expr (expr
);
3981 /* Stabilize the argument's value. */
3982 if (!sym
->attr
.function
&& se
)
3983 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3985 if (sym
->ts
.type
== BT_CHARACTER
)
3987 /* Create a copy of the dummy argument's length. */
3988 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3989 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3991 /* If the length is specified as "*", record the length that
3992 the caller is passing. We should use the callee's length
3993 in all other cases. */
3994 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3996 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3997 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4004 /* Use the passed value as-is if the argument is a function. */
4005 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4008 /* If the argument is a pass-by-value scalar, use the value as is. */
4009 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4012 /* If the argument is either a string or a pointer to a string,
4013 convert it to a boundless character type. */
4014 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4016 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4017 tmp
= build_pointer_type (tmp
);
4018 if (sym
->attr
.pointer
)
4019 value
= build_fold_indirect_ref_loc (input_location
,
4023 value
= fold_convert (tmp
, value
);
4026 /* If the argument is a scalar, a pointer to an array or an allocatable,
4028 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4029 value
= build_fold_indirect_ref_loc (input_location
,
4032 /* For character(*), use the actual argument's descriptor. */
4033 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4034 value
= build_fold_indirect_ref_loc (input_location
,
4037 /* If the argument is an array descriptor, use it to determine
4038 information about the actual argument's shape. */
4039 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4040 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4042 /* Get the actual argument's descriptor. */
4043 desc
= build_fold_indirect_ref_loc (input_location
,
4046 /* Create the replacement variable. */
4047 tmp
= gfc_conv_descriptor_data_get (desc
);
4048 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4051 /* Use DESC to work out the upper bounds, strides and offset. */
4052 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4055 /* Otherwise we have a packed array. */
4056 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4057 PACKED_FULL
, se
->expr
);
4059 new_sym
->backend_decl
= value
;
4063 /* Called once all dummy argument mappings have been added to MAPPING,
4064 but before the mapping is used to evaluate expressions. Pre-evaluate
4065 the length of each argument, adding any initialization code to PRE and
4066 any finalization code to POST. */
4069 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4070 stmtblock_t
* pre
, stmtblock_t
* post
)
4072 gfc_interface_sym_mapping
*sym
;
4076 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4077 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4078 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4080 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4081 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4082 gfc_init_se (&se
, NULL
);
4083 gfc_conv_expr (&se
, expr
);
4084 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4085 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4086 gfc_add_block_to_block (pre
, &se
.pre
);
4087 gfc_add_block_to_block (post
, &se
.post
);
4089 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4094 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4098 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4099 gfc_constructor_base base
)
4102 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4104 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4107 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4108 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4109 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4115 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4119 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4124 for (; ref
; ref
= ref
->next
)
4128 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4130 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4131 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4132 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4140 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4141 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4147 /* Convert intrinsic function calls into result expressions. */
4150 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4158 arg1
= expr
->value
.function
.actual
->expr
;
4159 if (expr
->value
.function
.actual
->next
)
4160 arg2
= expr
->value
.function
.actual
->next
->expr
;
4164 sym
= arg1
->symtree
->n
.sym
;
4166 if (sym
->attr
.dummy
)
4171 switch (expr
->value
.function
.isym
->id
)
4174 /* TODO figure out why this condition is necessary. */
4175 if (sym
->attr
.function
4176 && (arg1
->ts
.u
.cl
->length
== NULL
4177 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4178 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4181 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4184 case GFC_ISYM_LEN_TRIM
:
4185 new_expr
= gfc_copy_expr (arg1
);
4186 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4191 gfc_replace_expr (arg1
, new_expr
);
4195 if (!sym
->as
|| sym
->as
->rank
== 0)
4198 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4200 dup
= mpz_get_si (arg2
->value
.integer
);
4205 dup
= sym
->as
->rank
;
4209 for (; d
< dup
; d
++)
4213 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4215 gfc_free_expr (new_expr
);
4219 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4220 gfc_get_int_expr (gfc_default_integer_kind
,
4222 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4224 new_expr
= gfc_multiply (new_expr
, tmp
);
4230 case GFC_ISYM_LBOUND
:
4231 case GFC_ISYM_UBOUND
:
4232 /* TODO These implementations of lbound and ubound do not limit if
4233 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4235 if (!sym
->as
|| sym
->as
->rank
== 0)
4238 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4239 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4243 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4245 if (sym
->as
->lower
[d
])
4246 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4250 if (sym
->as
->upper
[d
])
4251 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4259 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4263 gfc_replace_expr (expr
, new_expr
);
4269 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4270 gfc_interface_mapping
* mapping
)
4272 gfc_formal_arglist
*f
;
4273 gfc_actual_arglist
*actual
;
4275 actual
= expr
->value
.function
.actual
;
4276 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4278 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4283 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4286 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4291 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4293 for (d
= 0; d
< as
->rank
; d
++)
4295 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4296 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4299 expr
->value
.function
.esym
->as
= as
;
4302 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4304 expr
->value
.function
.esym
->ts
.u
.cl
->length
4305 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4307 gfc_apply_interface_mapping_to_expr (mapping
,
4308 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4313 /* EXPR is a copy of an expression that appeared in the interface
4314 associated with MAPPING. Walk it recursively looking for references to
4315 dummy arguments that MAPPING maps to actual arguments. Replace each such
4316 reference with a reference to the associated actual argument. */
4319 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4322 gfc_interface_sym_mapping
*sym
;
4323 gfc_actual_arglist
*actual
;
4328 /* Copying an expression does not copy its length, so do that here. */
4329 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4331 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4332 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4335 /* Apply the mapping to any references. */
4336 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4338 /* ...and to the expression's symbol, if it has one. */
4339 /* TODO Find out why the condition on expr->symtree had to be moved into
4340 the loop rather than being outside it, as originally. */
4341 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4342 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4344 if (sym
->new_sym
->n
.sym
->backend_decl
)
4345 expr
->symtree
= sym
->new_sym
;
4347 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4350 /* ...and to subexpressions in expr->value. */
4351 switch (expr
->expr_type
)
4356 case EXPR_SUBSTRING
:
4360 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4361 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4365 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4366 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4368 if (expr
->value
.function
.esym
== NULL
4369 && expr
->value
.function
.isym
!= NULL
4370 && expr
->value
.function
.actual
4371 && expr
->value
.function
.actual
->expr
4372 && expr
->value
.function
.actual
->expr
->symtree
4373 && gfc_map_intrinsic_function (expr
, mapping
))
4376 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4377 if (sym
->old
== expr
->value
.function
.esym
)
4379 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4380 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4381 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4386 case EXPR_STRUCTURE
:
4387 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4400 /* Evaluate interface expression EXPR using MAPPING. Store the result
4404 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4405 gfc_se
* se
, gfc_expr
* expr
)
4407 expr
= gfc_copy_expr (expr
);
4408 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4409 gfc_conv_expr (se
, expr
);
4410 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4411 gfc_free_expr (expr
);
4415 /* Returns a reference to a temporary array into which a component of
4416 an actual argument derived type array is copied and then returned
4417 after the function call. */
4419 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4420 sym_intent intent
, bool formal_ptr
)
4428 gfc_array_info
*info
;
4438 gfc_init_se (&lse
, NULL
);
4439 gfc_init_se (&rse
, NULL
);
4441 /* Walk the argument expression. */
4442 rss
= gfc_walk_expr (expr
);
4444 gcc_assert (rss
!= gfc_ss_terminator
);
4446 /* Initialize the scalarizer. */
4447 gfc_init_loopinfo (&loop
);
4448 gfc_add_ss_to_loop (&loop
, rss
);
4450 /* Calculate the bounds of the scalarization. */
4451 gfc_conv_ss_startstride (&loop
);
4453 /* Build an ss for the temporary. */
4454 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4455 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4457 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4458 if (GFC_ARRAY_TYPE_P (base_type
)
4459 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4460 base_type
= gfc_get_element_type (base_type
);
4462 if (expr
->ts
.type
== BT_CLASS
)
4463 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4465 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4466 ? expr
->ts
.u
.cl
->backend_decl
4470 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4472 /* Associate the SS with the loop. */
4473 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4475 /* Setup the scalarizing loops. */
4476 gfc_conv_loop_setup (&loop
, &expr
->where
);
4478 /* Pass the temporary descriptor back to the caller. */
4479 info
= &loop
.temp_ss
->info
->data
.array
;
4480 parmse
->expr
= info
->descriptor
;
4482 /* Setup the gfc_se structures. */
4483 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4484 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4487 lse
.ss
= loop
.temp_ss
;
4488 gfc_mark_ss_chain_used (rss
, 1);
4489 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4491 /* Start the scalarized loop body. */
4492 gfc_start_scalarized_body (&loop
, &body
);
4494 /* Translate the expression. */
4495 gfc_conv_expr (&rse
, expr
);
4497 /* Reset the offset for the function call since the loop
4498 is zero based on the data pointer. Note that the temp
4499 comes first in the loop chain since it is added second. */
4500 if (gfc_is_class_array_function (expr
))
4502 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4503 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4504 gfc_index_zero_node
);
4507 gfc_conv_tmp_array_ref (&lse
);
4509 if (intent
!= INTENT_OUT
)
4511 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4512 gfc_add_expr_to_block (&body
, tmp
);
4513 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4514 gfc_trans_scalarizing_loops (&loop
, &body
);
4518 /* Make sure that the temporary declaration survives by merging
4519 all the loop declarations into the current context. */
4520 for (n
= 0; n
< loop
.dimen
; n
++)
4522 gfc_merge_block_scope (&body
);
4523 body
= loop
.code
[loop
.order
[n
]];
4525 gfc_merge_block_scope (&body
);
4528 /* Add the post block after the second loop, so that any
4529 freeing of allocated memory is done at the right time. */
4530 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4532 /**********Copy the temporary back again.*********/
4534 gfc_init_se (&lse
, NULL
);
4535 gfc_init_se (&rse
, NULL
);
4537 /* Walk the argument expression. */
4538 lss
= gfc_walk_expr (expr
);
4539 rse
.ss
= loop
.temp_ss
;
4542 /* Initialize the scalarizer. */
4543 gfc_init_loopinfo (&loop2
);
4544 gfc_add_ss_to_loop (&loop2
, lss
);
4546 dimen
= rse
.ss
->dimen
;
4548 /* Skip the write-out loop for this case. */
4549 if (gfc_is_class_array_function (expr
))
4550 goto class_array_fcn
;
4552 /* Calculate the bounds of the scalarization. */
4553 gfc_conv_ss_startstride (&loop2
);
4555 /* Setup the scalarizing loops. */
4556 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4558 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4559 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4561 gfc_mark_ss_chain_used (lss
, 1);
4562 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4564 /* Declare the variable to hold the temporary offset and start the
4565 scalarized loop body. */
4566 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4567 gfc_start_scalarized_body (&loop2
, &body
);
4569 /* Build the offsets for the temporary from the loop variables. The
4570 temporary array has lbounds of zero and strides of one in all
4571 dimensions, so this is very simple. The offset is only computed
4572 outside the innermost loop, so the overall transfer could be
4573 optimized further. */
4574 info
= &rse
.ss
->info
->data
.array
;
4576 tmp_index
= gfc_index_zero_node
;
4577 for (n
= dimen
- 1; n
> 0; n
--)
4580 tmp
= rse
.loop
->loopvar
[n
];
4581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4582 tmp
, rse
.loop
->from
[n
]);
4583 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4586 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4587 gfc_array_index_type
,
4588 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4589 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4590 gfc_array_index_type
,
4591 tmp_str
, gfc_index_one_node
);
4593 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4594 gfc_array_index_type
, tmp
, tmp_str
);
4597 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4598 gfc_array_index_type
,
4599 tmp_index
, rse
.loop
->from
[0]);
4600 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4602 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4603 gfc_array_index_type
,
4604 rse
.loop
->loopvar
[0], offset
);
4606 /* Now use the offset for the reference. */
4607 tmp
= build_fold_indirect_ref_loc (input_location
,
4609 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4611 if (expr
->ts
.type
== BT_CHARACTER
)
4612 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4614 gfc_conv_expr (&lse
, expr
);
4616 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4618 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4619 gfc_add_expr_to_block (&body
, tmp
);
4621 /* Generate the copying loops. */
4622 gfc_trans_scalarizing_loops (&loop2
, &body
);
4624 /* Wrap the whole thing up by adding the second loop to the post-block
4625 and following it by the post-block of the first loop. In this way,
4626 if the temporary needs freeing, it is done after use! */
4627 if (intent
!= INTENT_IN
)
4629 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4630 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4635 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4637 gfc_cleanup_loop (&loop
);
4638 gfc_cleanup_loop (&loop2
);
4640 /* Pass the string length to the argument expression. */
4641 if (expr
->ts
.type
== BT_CHARACTER
)
4642 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4644 /* Determine the offset for pointer formal arguments and set the
4648 size
= gfc_index_one_node
;
4649 offset
= gfc_index_zero_node
;
4650 for (n
= 0; n
< dimen
; n
++)
4652 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4654 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4655 gfc_array_index_type
, tmp
,
4656 gfc_index_one_node
);
4657 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4661 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4664 gfc_index_one_node
);
4665 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4666 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4667 gfc_array_index_type
,
4669 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4670 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4671 gfc_array_index_type
,
4672 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4673 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4674 gfc_array_index_type
,
4675 tmp
, gfc_index_one_node
);
4676 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4677 gfc_array_index_type
, size
, tmp
);
4680 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4684 /* We want either the address for the data or the address of the descriptor,
4685 depending on the mode of passing array arguments. */
4687 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4689 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4695 /* Generate the code for argument list functions. */
4698 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4700 /* Pass by value for g77 %VAL(arg), pass the address
4701 indirectly for %LOC, else by reference. Thus %REF
4702 is a "do-nothing" and %LOC is the same as an F95
4704 if (strcmp (name
, "%VAL") == 0)
4705 gfc_conv_expr (se
, expr
);
4706 else if (strcmp (name
, "%LOC") == 0)
4708 gfc_conv_expr_reference (se
, expr
);
4709 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4711 else if (strcmp (name
, "%REF") == 0)
4712 gfc_conv_expr_reference (se
, expr
);
4714 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4718 /* This function tells whether the middle-end representation of the expression
4719 E given as input may point to data otherwise accessible through a variable
4721 It is assumed that the only expressions that may alias are variables,
4722 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4724 This function is used to decide whether freeing an expression's allocatable
4725 components is safe or should be avoided.
4727 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4728 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4729 is necessary because for array constructors, aliasing depends on how
4731 - If E is an array constructor used as argument to an elemental procedure,
4732 the array, which is generated through shallow copy by the scalarizer,
4733 is used directly and can alias the expressions it was copied from.
4734 - If E is an array constructor used as argument to a non-elemental
4735 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4736 the array as in the previous case, but then that array is used
4737 to initialize a new descriptor through deep copy. There is no alias
4738 possible in that case.
4739 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4743 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4747 if (e
->expr_type
== EXPR_VARIABLE
)
4749 else if (e
->expr_type
== EXPR_FUNCTION
)
4751 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4753 if (proc_ifc
->result
!= NULL
4754 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4755 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4756 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4757 || proc_ifc
->result
->attr
.pointer
))
4762 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4765 for (c
= gfc_constructor_first (e
->value
.constructor
);
4766 c
; c
= gfc_constructor_next (c
))
4768 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4775 /* Generate code for a procedure call. Note can return se->post != NULL.
4776 If se->direct_byref is set then se->expr contains the return parameter.
4777 Return nonzero, if the call has alternate specifiers.
4778 'expr' is only needed for procedure pointer components. */
4781 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4782 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4783 vec
<tree
, va_gc
> *append_args
)
4785 gfc_interface_mapping mapping
;
4786 vec
<tree
, va_gc
> *arglist
;
4787 vec
<tree
, va_gc
> *retargs
;
4791 gfc_array_info
*info
;
4798 vec
<tree
, va_gc
> *stringargs
;
4799 vec
<tree
, va_gc
> *optionalargs
;
4801 gfc_formal_arglist
*formal
;
4802 gfc_actual_arglist
*arg
;
4803 int has_alternate_specifier
= 0;
4804 bool need_interface_mapping
;
4812 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4813 gfc_component
*comp
= NULL
;
4820 optionalargs
= NULL
;
4825 comp
= gfc_get_proc_ptr_comp (expr
);
4827 bool elemental_proc
= (comp
4828 && comp
->ts
.interface
4829 && comp
->ts
.interface
->attr
.elemental
)
4830 || (comp
&& comp
->attr
.elemental
)
4831 || sym
->attr
.elemental
;
4835 if (!elemental_proc
)
4837 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4838 if (se
->ss
->info
->useflags
)
4840 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4841 && sym
->result
->attr
.dimension
)
4842 || (comp
&& comp
->attr
.dimension
)
4843 || gfc_is_class_array_function (expr
));
4844 gcc_assert (se
->loop
!= NULL
);
4845 /* Access the previously obtained result. */
4846 gfc_conv_tmp_array_ref (se
);
4850 info
= &se
->ss
->info
->data
.array
;
4855 gfc_init_block (&post
);
4856 gfc_init_interface_mapping (&mapping
);
4859 formal
= gfc_sym_get_dummy_args (sym
);
4860 need_interface_mapping
= sym
->attr
.dimension
||
4861 (sym
->ts
.type
== BT_CHARACTER
4862 && sym
->ts
.u
.cl
->length
4863 && sym
->ts
.u
.cl
->length
->expr_type
4868 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4869 need_interface_mapping
= comp
->attr
.dimension
||
4870 (comp
->ts
.type
== BT_CHARACTER
4871 && comp
->ts
.u
.cl
->length
4872 && comp
->ts
.u
.cl
->length
->expr_type
4876 base_object
= NULL_TREE
;
4877 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4878 is the third and fourth argument to such a function call a value
4879 denoting the number of elements to copy (i.e., most of the time the
4880 length of a deferred length string). */
4881 ulim_copy
= (formal
== NULL
)
4882 && UNLIMITED_POLY (sym
)
4883 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4885 /* Evaluate the arguments. */
4886 for (arg
= args
, argc
= 0; arg
!= NULL
;
4887 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4889 bool finalized
= false;
4892 fsym
= formal
? formal
->sym
: NULL
;
4893 parm_kind
= MISSING
;
4895 /* If the procedure requires an explicit interface, the actual
4896 argument is passed according to the corresponding formal
4897 argument. If the corresponding formal argument is a POINTER,
4898 ALLOCATABLE or assumed shape, we do not use g77's calling
4899 convention, and pass the address of the array descriptor
4900 instead. Otherwise we use g77's calling convention, in other words
4901 pass the array data pointer without descriptor. */
4902 bool nodesc_arg
= fsym
!= NULL
4903 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4905 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4906 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4908 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4910 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4912 /* Class array expressions are sometimes coming completely unadorned
4913 with either arrayspec or _data component. Correct that here.
4914 OOP-TODO: Move this to the frontend. */
4915 if (e
&& e
->expr_type
== EXPR_VARIABLE
4917 && e
->ts
.type
== BT_CLASS
4918 && (CLASS_DATA (e
)->attr
.codimension
4919 || CLASS_DATA (e
)->attr
.dimension
))
4921 gfc_typespec temp_ts
= e
->ts
;
4922 gfc_add_class_array_ref (e
);
4928 if (se
->ignore_optional
)
4930 /* Some intrinsics have already been resolved to the correct
4934 else if (arg
->label
)
4936 has_alternate_specifier
= 1;
4941 gfc_init_se (&parmse
, NULL
);
4943 /* For scalar arguments with VALUE attribute which are passed by
4944 value, pass "0" and a hidden argument gives the optional
4946 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4947 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4948 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4950 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4952 vec_safe_push (optionalargs
, boolean_false_node
);
4956 /* Pass a NULL pointer for an absent arg. */
4957 parmse
.expr
= null_pointer_node
;
4958 if (arg
->missing_arg_type
== BT_CHARACTER
)
4959 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4964 else if (arg
->expr
->expr_type
== EXPR_NULL
4965 && fsym
&& !fsym
->attr
.pointer
4966 && (fsym
->ts
.type
!= BT_CLASS
4967 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4969 /* Pass a NULL pointer to denote an absent arg. */
4970 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4971 && (fsym
->ts
.type
!= BT_CLASS
4972 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4973 gfc_init_se (&parmse
, NULL
);
4974 parmse
.expr
= null_pointer_node
;
4975 if (arg
->missing_arg_type
== BT_CHARACTER
)
4976 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4978 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4979 && e
->ts
.type
== BT_DERIVED
)
4981 /* The derived type needs to be converted to a temporary
4983 gfc_init_se (&parmse
, se
);
4984 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4986 && e
->expr_type
== EXPR_VARIABLE
4987 && e
->symtree
->n
.sym
->attr
.optional
,
4988 CLASS_DATA (fsym
)->attr
.class_pointer
4989 || CLASS_DATA (fsym
)->attr
.allocatable
);
4991 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4993 /* The intrinsic type needs to be converted to a temporary
4994 CLASS object for the unlimited polymorphic formal. */
4995 gfc_init_se (&parmse
, se
);
4996 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4998 else if (se
->ss
&& se
->ss
->info
->useflags
)
5004 /* An elemental function inside a scalarized loop. */
5005 gfc_init_se (&parmse
, se
);
5006 parm_kind
= ELEMENTAL
;
5008 /* When no fsym is present, ulim_copy is set and this is a third or
5009 fourth argument, use call-by-value instead of by reference to
5010 hand the length properties to the copy routine (i.e., most of the
5011 time this will be a call to a __copy_character_* routine where the
5012 third and fourth arguments are the lengths of a deferred length
5014 if ((fsym
&& fsym
->attr
.value
)
5015 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5016 gfc_conv_expr (&parmse
, e
);
5018 gfc_conv_expr_reference (&parmse
, e
);
5020 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5021 && e
->expr_type
== EXPR_FUNCTION
)
5022 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5025 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5026 && gfc_is_class_container_ref (e
))
5028 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5030 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5031 && e
->symtree
->n
.sym
->attr
.optional
)
5033 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5034 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5035 TREE_TYPE (parmse
.expr
),
5037 fold_convert (TREE_TYPE (parmse
.expr
),
5038 null_pointer_node
));
5042 /* If we are passing an absent array as optional dummy to an
5043 elemental procedure, make sure that we pass NULL when the data
5044 pointer is NULL. We need this extra conditional because of
5045 scalarization which passes arrays elements to the procedure,
5046 ignoring the fact that the array can be absent/unallocated/... */
5047 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5049 tree descriptor_data
;
5051 descriptor_data
= ss
->info
->data
.array
.data
;
5052 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5054 fold_convert (TREE_TYPE (descriptor_data
),
5055 null_pointer_node
));
5057 = fold_build3_loc (input_location
, COND_EXPR
,
5058 TREE_TYPE (parmse
.expr
),
5059 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5060 fold_convert (TREE_TYPE (parmse
.expr
),
5065 /* The scalarizer does not repackage the reference to a class
5066 array - instead it returns a pointer to the data element. */
5067 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5068 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5069 fsym
->attr
.intent
!= INTENT_IN
5070 && (CLASS_DATA (fsym
)->attr
.class_pointer
5071 || CLASS_DATA (fsym
)->attr
.allocatable
),
5073 && e
->expr_type
== EXPR_VARIABLE
5074 && e
->symtree
->n
.sym
->attr
.optional
,
5075 CLASS_DATA (fsym
)->attr
.class_pointer
5076 || CLASS_DATA (fsym
)->attr
.allocatable
);
5083 gfc_init_se (&parmse
, NULL
);
5085 /* Check whether the expression is a scalar or not; we cannot use
5086 e->rank as it can be nonzero for functions arguments. */
5087 argss
= gfc_walk_expr (e
);
5088 scalar
= argss
== gfc_ss_terminator
;
5090 gfc_free_ss_chain (argss
);
5092 /* Special handling for passing scalar polymorphic coarrays;
5093 otherwise one passes "class->_data.data" instead of "&class". */
5094 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5095 && fsym
&& fsym
->ts
.type
== BT_CLASS
5096 && CLASS_DATA (fsym
)->attr
.codimension
5097 && !CLASS_DATA (fsym
)->attr
.dimension
)
5099 gfc_add_class_array_ref (e
);
5100 parmse
.want_coarray
= 1;
5104 /* A scalar or transformational function. */
5107 if (e
->expr_type
== EXPR_VARIABLE
5108 && e
->symtree
->n
.sym
->attr
.cray_pointee
5109 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5111 /* The Cray pointer needs to be converted to a pointer to
5112 a type given by the expression. */
5113 gfc_conv_expr (&parmse
, e
);
5114 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5115 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5116 parmse
.expr
= convert (type
, tmp
);
5118 else if (fsym
&& fsym
->attr
.value
)
5120 if (fsym
->ts
.type
== BT_CHARACTER
5121 && fsym
->ts
.is_c_interop
5122 && fsym
->ns
->proc_name
!= NULL
5123 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5126 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5127 if (parmse
.expr
== NULL
)
5128 gfc_conv_expr (&parmse
, e
);
5132 gfc_conv_expr (&parmse
, e
);
5133 if (fsym
->attr
.optional
5134 && fsym
->ts
.type
!= BT_CLASS
5135 && fsym
->ts
.type
!= BT_DERIVED
)
5137 if (e
->expr_type
!= EXPR_VARIABLE
5138 || !e
->symtree
->n
.sym
->attr
.optional
5140 vec_safe_push (optionalargs
, boolean_true_node
);
5143 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5144 if (!e
->symtree
->n
.sym
->attr
.value
)
5146 = fold_build3_loc (input_location
, COND_EXPR
,
5147 TREE_TYPE (parmse
.expr
),
5149 fold_convert (TREE_TYPE (parmse
.expr
),
5150 integer_zero_node
));
5152 vec_safe_push (optionalargs
, tmp
);
5157 else if (arg
->name
&& arg
->name
[0] == '%')
5158 /* Argument list functions %VAL, %LOC and %REF are signalled
5159 through arg->name. */
5160 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5161 else if ((e
->expr_type
== EXPR_FUNCTION
)
5162 && ((e
->value
.function
.esym
5163 && e
->value
.function
.esym
->result
->attr
.pointer
)
5164 || (!e
->value
.function
.esym
5165 && e
->symtree
->n
.sym
->attr
.pointer
))
5166 && fsym
&& fsym
->attr
.target
)
5168 gfc_conv_expr (&parmse
, e
);
5169 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5171 else if (e
->expr_type
== EXPR_FUNCTION
5172 && e
->symtree
->n
.sym
->result
5173 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5174 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5176 /* Functions returning procedure pointers. */
5177 gfc_conv_expr (&parmse
, e
);
5178 if (fsym
&& fsym
->attr
.proc_pointer
)
5179 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5183 if (e
->ts
.type
== BT_CLASS
&& fsym
5184 && fsym
->ts
.type
== BT_CLASS
5185 && (!CLASS_DATA (fsym
)->as
5186 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5187 && CLASS_DATA (e
)->attr
.codimension
)
5189 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5190 gcc_assert (!CLASS_DATA (fsym
)->as
);
5191 gfc_add_class_array_ref (e
);
5192 parmse
.want_coarray
= 1;
5193 gfc_conv_expr_reference (&parmse
, e
);
5194 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5196 && e
->expr_type
== EXPR_VARIABLE
);
5198 else if (e
->ts
.type
== BT_CLASS
&& fsym
5199 && fsym
->ts
.type
== BT_CLASS
5200 && !CLASS_DATA (fsym
)->as
5201 && !CLASS_DATA (e
)->as
5202 && strcmp (fsym
->ts
.u
.derived
->name
,
5203 e
->ts
.u
.derived
->name
))
5205 type
= gfc_typenode_for_spec (&fsym
->ts
);
5206 var
= gfc_create_var (type
, fsym
->name
);
5207 gfc_conv_expr (&parmse
, e
);
5208 if (fsym
->attr
.optional
5209 && e
->expr_type
== EXPR_VARIABLE
5210 && e
->symtree
->n
.sym
->attr
.optional
)
5214 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5215 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5216 logical_type_node
, tmp
,
5217 fold_convert (TREE_TYPE (tmp
),
5218 null_pointer_node
));
5219 gfc_start_block (&block
);
5220 gfc_add_modify (&block
, var
,
5221 fold_build1_loc (input_location
,
5223 type
, parmse
.expr
));
5224 gfc_add_expr_to_block (&parmse
.pre
,
5225 fold_build3_loc (input_location
,
5226 COND_EXPR
, void_type_node
,
5227 cond
, gfc_finish_block (&block
),
5228 build_empty_stmt (input_location
)));
5229 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5230 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5231 TREE_TYPE (parmse
.expr
),
5233 fold_convert (TREE_TYPE (parmse
.expr
),
5234 null_pointer_node
));
5238 /* Since the internal representation of unlimited
5239 polymorphic expressions includes an extra field
5240 that other class objects do not, a cast to the
5241 formal type does not work. */
5242 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5246 /* Set the _data field. */
5247 tmp
= gfc_class_data_get (var
);
5248 efield
= fold_convert (TREE_TYPE (tmp
),
5249 gfc_class_data_get (parmse
.expr
));
5250 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5252 /* Set the _vptr field. */
5253 tmp
= gfc_class_vptr_get (var
);
5254 efield
= fold_convert (TREE_TYPE (tmp
),
5255 gfc_class_vptr_get (parmse
.expr
));
5256 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5258 /* Set the _len field. */
5259 tmp
= gfc_class_len_get (var
);
5260 gfc_add_modify (&parmse
.pre
, tmp
,
5261 build_int_cst (TREE_TYPE (tmp
), 0));
5265 tmp
= fold_build1_loc (input_location
,
5268 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5271 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5277 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
5278 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
5279 && !e
->symtree
->n
.sym
->attr
.dimension
5280 && !e
->symtree
->n
.sym
->attr
.pointer
5282 && !e
->symtree
->n
.sym
->attr
.dummy
5283 /* FIXME - PR 87395 and PR 41453 */
5284 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
5285 && !e
->symtree
->n
.sym
->attr
.associate_var
5286 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
5287 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
5289 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
5291 /* Catch base objects that are not variables. */
5292 if (e
->ts
.type
== BT_CLASS
5293 && e
->expr_type
!= EXPR_VARIABLE
5294 && expr
&& e
== expr
->base_expr
)
5295 base_object
= build_fold_indirect_ref_loc (input_location
,
5298 /* A class array element needs converting back to be a
5299 class object, if the formal argument is a class object. */
5300 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5301 && e
->ts
.type
== BT_CLASS
5302 && ((CLASS_DATA (fsym
)->as
5303 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5304 || CLASS_DATA (e
)->attr
.dimension
))
5305 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5306 fsym
->attr
.intent
!= INTENT_IN
5307 && (CLASS_DATA (fsym
)->attr
.class_pointer
5308 || CLASS_DATA (fsym
)->attr
.allocatable
),
5310 && e
->expr_type
== EXPR_VARIABLE
5311 && e
->symtree
->n
.sym
->attr
.optional
,
5312 CLASS_DATA (fsym
)->attr
.class_pointer
5313 || CLASS_DATA (fsym
)->attr
.allocatable
);
5315 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5316 allocated on entry, it must be deallocated. */
5317 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5318 && (fsym
->attr
.allocatable
5319 || (fsym
->ts
.type
== BT_CLASS
5320 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5325 gfc_init_block (&block
);
5327 if (e
->ts
.type
== BT_CLASS
)
5328 ptr
= gfc_class_data_get (ptr
);
5330 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5333 gfc_add_expr_to_block (&block
, tmp
);
5334 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5335 void_type_node
, ptr
,
5337 gfc_add_expr_to_block (&block
, tmp
);
5339 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5341 gfc_add_modify (&block
, ptr
,
5342 fold_convert (TREE_TYPE (ptr
),
5343 null_pointer_node
));
5344 gfc_add_expr_to_block (&block
, tmp
);
5346 else if (fsym
->ts
.type
== BT_CLASS
)
5349 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5350 tmp
= gfc_get_symbol_decl (vtab
);
5351 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5352 ptr
= gfc_class_vptr_get (parmse
.expr
);
5353 gfc_add_modify (&block
, ptr
,
5354 fold_convert (TREE_TYPE (ptr
), tmp
));
5355 gfc_add_expr_to_block (&block
, tmp
);
5358 if (fsym
->attr
.optional
5359 && e
->expr_type
== EXPR_VARIABLE
5360 && e
->symtree
->n
.sym
->attr
.optional
)
5362 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5364 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5365 gfc_finish_block (&block
),
5366 build_empty_stmt (input_location
));
5369 tmp
= gfc_finish_block (&block
);
5371 gfc_add_expr_to_block (&se
->pre
, tmp
);
5374 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5375 || fsym
->ts
.type
== BT_ASSUMED
)
5376 && e
->ts
.type
== BT_CLASS
5377 && !CLASS_DATA (e
)->attr
.dimension
5378 && !CLASS_DATA (e
)->attr
.codimension
)
5380 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5381 /* The result is a class temporary, whose _data component
5382 must be freed to avoid a memory leak. */
5383 if (e
->expr_type
== EXPR_FUNCTION
5384 && CLASS_DATA (e
)->attr
.allocatable
)
5390 /* Borrow the function symbol to make a call to
5391 gfc_add_finalizer_call and then restore it. */
5392 tmp
= e
->symtree
->n
.sym
->backend_decl
;
5393 e
->symtree
->n
.sym
->backend_decl
5394 = TREE_OPERAND (parmse
.expr
, 0);
5395 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5396 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
5397 finalized
= gfc_add_finalizer_call (&parmse
.post
,
5399 gfc_free_expr (var
);
5400 e
->symtree
->n
.sym
->backend_decl
= tmp
;
5401 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5403 /* Then free the class _data. */
5404 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
5405 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5408 tmp
= build3_v (COND_EXPR
, tmp
,
5409 gfc_call_free (parmse
.expr
),
5410 build_empty_stmt (input_location
));
5411 gfc_add_expr_to_block (&parmse
.post
, tmp
);
5412 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
5416 /* Wrap scalar variable in a descriptor. We need to convert
5417 the address of a pointer back to the pointer itself before,
5418 we can assign it to the data field. */
5420 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5421 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5424 if (TREE_CODE (tmp
) == ADDR_EXPR
)
5425 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5426 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5428 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5431 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5432 && ((fsym
->attr
.pointer
5433 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5434 || (fsym
->attr
.proc_pointer
5435 && !(e
->expr_type
== EXPR_VARIABLE
5436 && e
->symtree
->n
.sym
->attr
.dummy
))
5437 || (fsym
->attr
.proc_pointer
5438 && e
->expr_type
== EXPR_VARIABLE
5439 && gfc_is_proc_ptr_comp (e
))
5440 || (fsym
->attr
.allocatable
5441 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5443 /* Scalar pointer dummy args require an extra level of
5444 indirection. The null pointer already contains
5445 this level of indirection. */
5446 parm_kind
= SCALAR_POINTER
;
5447 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5451 else if (e
->ts
.type
== BT_CLASS
5452 && fsym
&& fsym
->ts
.type
== BT_CLASS
5453 && (CLASS_DATA (fsym
)->attr
.dimension
5454 || CLASS_DATA (fsym
)->attr
.codimension
))
5456 /* Pass a class array. */
5457 parmse
.use_offset
= 1;
5458 gfc_conv_expr_descriptor (&parmse
, e
);
5460 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5461 allocated on entry, it must be deallocated. */
5462 if (fsym
->attr
.intent
== INTENT_OUT
5463 && CLASS_DATA (fsym
)->attr
.allocatable
)
5468 gfc_init_block (&block
);
5470 ptr
= gfc_class_data_get (ptr
);
5472 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5473 NULL_TREE
, NULL_TREE
,
5475 GFC_CAF_COARRAY_NOCOARRAY
);
5476 gfc_add_expr_to_block (&block
, tmp
);
5477 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5478 void_type_node
, ptr
,
5480 gfc_add_expr_to_block (&block
, tmp
);
5481 gfc_reset_vptr (&block
, e
);
5483 if (fsym
->attr
.optional
5484 && e
->expr_type
== EXPR_VARIABLE
5486 || (e
->ref
->type
== REF_ARRAY
5487 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5488 && e
->symtree
->n
.sym
->attr
.optional
)
5490 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5492 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5493 gfc_finish_block (&block
),
5494 build_empty_stmt (input_location
));
5497 tmp
= gfc_finish_block (&block
);
5499 gfc_add_expr_to_block (&se
->pre
, tmp
);
5502 /* The conversion does not repackage the reference to a class
5503 array - _data descriptor. */
5504 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5505 fsym
->attr
.intent
!= INTENT_IN
5506 && (CLASS_DATA (fsym
)->attr
.class_pointer
5507 || CLASS_DATA (fsym
)->attr
.allocatable
),
5509 && e
->expr_type
== EXPR_VARIABLE
5510 && e
->symtree
->n
.sym
->attr
.optional
,
5511 CLASS_DATA (fsym
)->attr
.class_pointer
5512 || CLASS_DATA (fsym
)->attr
.allocatable
);
5516 /* If the argument is a function call that may not create
5517 a temporary for the result, we have to check that we
5518 can do it, i.e. that there is no alias between this
5519 argument and another one. */
5520 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5526 intent
= fsym
->attr
.intent
;
5528 intent
= INTENT_UNKNOWN
;
5530 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5532 parmse
.force_tmp
= 1;
5534 iarg
= e
->value
.function
.actual
->expr
;
5536 /* Temporary needed if aliasing due to host association. */
5537 if (sym
->attr
.contained
5539 && !sym
->attr
.implicit_pure
5540 && !sym
->attr
.use_assoc
5541 && iarg
->expr_type
== EXPR_VARIABLE
5542 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5543 parmse
.force_tmp
= 1;
5545 /* Ditto within module. */
5546 if (sym
->attr
.use_assoc
5548 && !sym
->attr
.implicit_pure
5549 && iarg
->expr_type
== EXPR_VARIABLE
5550 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5551 parmse
.force_tmp
= 1;
5554 if (e
->expr_type
== EXPR_VARIABLE
5555 && is_subref_array (e
)
5556 && !(fsym
&& fsym
->attr
.pointer
))
5557 /* The actual argument is a component reference to an
5558 array of derived types. In this case, the argument
5559 is converted to a temporary, which is passed and then
5560 written back after the procedure call. */
5561 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5562 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5563 fsym
&& fsym
->attr
.pointer
);
5564 else if (gfc_is_class_array_ref (e
, NULL
)
5565 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5566 /* The actual argument is a component reference to an
5567 array of derived types. In this case, the argument
5568 is converted to a temporary, which is passed and then
5569 written back after the procedure call.
5570 OOP-TODO: Insert code so that if the dynamic type is
5571 the same as the declared type, copy-in/copy-out does
5573 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5574 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5575 fsym
&& fsym
->attr
.pointer
);
5577 else if (gfc_is_class_array_function (e
)
5578 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5579 /* See previous comment. For function actual argument,
5580 the write out is not needed so the intent is set as
5583 e
->must_finalize
= 1;
5584 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5586 fsym
&& fsym
->attr
.pointer
);
5589 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5592 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5593 allocated on entry, it must be deallocated. */
5594 if (fsym
&& fsym
->attr
.allocatable
5595 && fsym
->attr
.intent
== INTENT_OUT
)
5597 if (fsym
->ts
.type
== BT_DERIVED
5598 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5600 // deallocate the components first
5601 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5602 parmse
.expr
, e
->rank
);
5603 if (tmp
!= NULL_TREE
)
5604 gfc_add_expr_to_block (&se
->pre
, tmp
);
5607 tmp
= build_fold_indirect_ref_loc (input_location
,
5609 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5610 tmp
= gfc_conv_descriptor_data_get (tmp
);
5611 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5612 NULL_TREE
, NULL_TREE
, true,
5614 GFC_CAF_COARRAY_NOCOARRAY
);
5615 if (fsym
->attr
.optional
5616 && e
->expr_type
== EXPR_VARIABLE
5617 && e
->symtree
->n
.sym
->attr
.optional
)
5618 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5620 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5621 tmp
, build_empty_stmt (input_location
));
5622 gfc_add_expr_to_block (&se
->pre
, tmp
);
5627 /* The case with fsym->attr.optional is that of a user subroutine
5628 with an interface indicating an optional argument. When we call
5629 an intrinsic subroutine, however, fsym is NULL, but we might still
5630 have an optional argument, so we proceed to the substitution
5632 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5634 /* If an optional argument is itself an optional dummy argument,
5635 check its presence and substitute a null if absent. This is
5636 only needed when passing an array to an elemental procedure
5637 as then array elements are accessed - or no NULL pointer is
5638 allowed and a "1" or "0" should be passed if not present.
5639 When passing a non-array-descriptor full array to a
5640 non-array-descriptor dummy, no check is needed. For
5641 array-descriptor actual to array-descriptor dummy, see
5642 PR 41911 for why a check has to be inserted.
5643 fsym == NULL is checked as intrinsics required the descriptor
5644 but do not always set fsym. */
5645 if (e
->expr_type
== EXPR_VARIABLE
5646 && e
->symtree
->n
.sym
->attr
.optional
5647 && ((e
->rank
!= 0 && elemental_proc
)
5648 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5652 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5653 || fsym
->as
->type
== AS_ASSUMED_RANK
5654 || fsym
->as
->type
== AS_DEFERRED
))))))
5655 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5656 e
->representation
.length
);
5661 /* Obtain the character length of an assumed character length
5662 length procedure from the typespec. */
5663 if (fsym
->ts
.type
== BT_CHARACTER
5664 && parmse
.string_length
== NULL_TREE
5665 && e
->ts
.type
== BT_PROCEDURE
5666 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5667 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5668 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5670 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5671 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5675 if (fsym
&& need_interface_mapping
&& e
)
5676 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5678 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5679 gfc_add_block_to_block (&post
, &parmse
.post
);
5681 /* Allocated allocatable components of derived types must be
5682 deallocated for non-variable scalars, array arguments to elemental
5683 procedures, and array arguments with descriptor to non-elemental
5684 procedures. As bounds information for descriptorless arrays is no
5685 longer available here, they are dealt with in trans-array.c
5686 (gfc_conv_array_parameter). */
5687 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5688 && e
->ts
.u
.derived
->attr
.alloc_comp
5689 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5690 && !expr_may_alias_variables (e
, elemental_proc
))
5693 /* It is known the e returns a structure type with at least one
5694 allocatable component. When e is a function, ensure that the
5695 function is called once only by using a temporary variable. */
5696 if (!DECL_P (parmse
.expr
))
5697 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5698 parmse
.expr
, &se
->pre
);
5700 if (fsym
&& fsym
->attr
.value
)
5703 tmp
= build_fold_indirect_ref_loc (input_location
,
5706 parm_rank
= e
->rank
;
5714 case (SCALAR_POINTER
):
5715 tmp
= build_fold_indirect_ref_loc (input_location
,
5720 if (e
->expr_type
== EXPR_OP
5721 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5722 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5725 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5726 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5728 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5731 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5733 /* The derived type is passed to gfc_deallocate_alloc_comp.
5734 Therefore, class actuals can handled correctly but derived
5735 types passed to class formals need the _data component. */
5736 tmp
= gfc_class_data_get (tmp
);
5737 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5738 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5741 if (!finalized
&& !e
->must_finalize
)
5743 if ((e
->ts
.type
== BT_CLASS
5744 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
5745 || e
->ts
.type
== BT_DERIVED
)
5746 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
5748 else if (e
->ts
.type
== BT_CLASS
)
5749 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
5751 gfc_prepend_expr_to_block (&post
, tmp
);
5755 /* Add argument checking of passing an unallocated/NULL actual to
5756 a nonallocatable/nonpointer dummy. */
5758 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5760 symbol_attribute attr
;
5764 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5765 attr
= gfc_expr_attr (e
);
5767 goto end_pointer_check
;
5769 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5770 allocatable to an optional dummy, cf. 12.5.2.12. */
5771 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5772 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5773 goto end_pointer_check
;
5777 /* If the actual argument is an optional pointer/allocatable and
5778 the formal argument takes an nonpointer optional value,
5779 it is invalid to pass a non-present argument on, even
5780 though there is no technical reason for this in gfortran.
5781 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5782 tree present
, null_ptr
, type
;
5784 if (attr
.allocatable
5785 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5786 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5787 "allocated or not present",
5788 e
->symtree
->n
.sym
->name
);
5789 else if (attr
.pointer
5790 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5791 msg
= xasprintf ("Pointer actual argument '%s' is not "
5792 "associated or not present",
5793 e
->symtree
->n
.sym
->name
);
5794 else if (attr
.proc_pointer
5795 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5796 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5797 "associated or not present",
5798 e
->symtree
->n
.sym
->name
);
5800 goto end_pointer_check
;
5802 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5803 type
= TREE_TYPE (present
);
5804 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5805 logical_type_node
, present
,
5807 null_pointer_node
));
5808 type
= TREE_TYPE (parmse
.expr
);
5809 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5810 logical_type_node
, parmse
.expr
,
5812 null_pointer_node
));
5813 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5814 logical_type_node
, present
, null_ptr
);
5818 if (attr
.allocatable
5819 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5820 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5821 "allocated", e
->symtree
->n
.sym
->name
);
5822 else if (attr
.pointer
5823 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5824 msg
= xasprintf ("Pointer actual argument '%s' is not "
5825 "associated", e
->symtree
->n
.sym
->name
);
5826 else if (attr
.proc_pointer
5827 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5828 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5829 "associated", e
->symtree
->n
.sym
->name
);
5831 goto end_pointer_check
;
5835 /* If the argument is passed by value, we need to strip the
5837 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5838 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5840 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5841 logical_type_node
, tmp
,
5842 fold_convert (TREE_TYPE (tmp
),
5843 null_pointer_node
));
5846 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5852 /* Deferred length dummies pass the character length by reference
5853 so that the value can be returned. */
5854 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5856 if (INDIRECT_REF_P (parmse
.string_length
))
5857 /* In chains of functions/procedure calls the string_length already
5858 is a pointer to the variable holding the length. Therefore
5859 remove the deref on call. */
5860 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5863 tmp
= parmse
.string_length
;
5864 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5865 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5866 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5870 /* Character strings are passed as two parameters, a length and a
5871 pointer - except for Bind(c) which only passes the pointer.
5872 An unlimited polymorphic formal argument likewise does not
5874 if (parmse
.string_length
!= NULL_TREE
5875 && !sym
->attr
.is_bind_c
5876 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5877 vec_safe_push (stringargs
, parmse
.string_length
);
5879 /* When calling __copy for character expressions to unlimited
5880 polymorphic entities, the dst argument needs a string length. */
5881 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5882 && gfc_str_startswith (sym
->name
, "__vtab_CHARACTER")
5883 && arg
->next
&& arg
->next
->expr
5884 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5885 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5886 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5887 vec_safe_push (stringargs
, parmse
.string_length
);
5889 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5890 pass the token and the offset as additional arguments. */
5891 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5892 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5893 && !fsym
->attr
.allocatable
)
5894 || (fsym
->ts
.type
== BT_CLASS
5895 && CLASS_DATA (fsym
)->attr
.codimension
5896 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5898 /* Token and offset. */
5899 vec_safe_push (stringargs
, null_pointer_node
);
5900 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5901 gcc_assert (fsym
->attr
.optional
);
5903 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5904 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5905 && !fsym
->attr
.allocatable
)
5906 || (fsym
->ts
.type
== BT_CLASS
5907 && CLASS_DATA (fsym
)->attr
.codimension
5908 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5910 tree caf_decl
, caf_type
;
5913 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5914 caf_type
= TREE_TYPE (caf_decl
);
5916 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5917 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5918 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5919 tmp
= gfc_conv_descriptor_token (caf_decl
);
5920 else if (DECL_LANG_SPECIFIC (caf_decl
)
5921 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5922 tmp
= GFC_DECL_TOKEN (caf_decl
);
5925 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5926 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5927 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5930 vec_safe_push (stringargs
, tmp
);
5932 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5933 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5934 offset
= build_int_cst (gfc_array_index_type
, 0);
5935 else if (DECL_LANG_SPECIFIC (caf_decl
)
5936 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5937 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5938 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5939 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5941 offset
= build_int_cst (gfc_array_index_type
, 0);
5943 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5944 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5947 gcc_assert (POINTER_TYPE_P (caf_type
));
5951 tmp2
= fsym
->ts
.type
== BT_CLASS
5952 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5953 if ((fsym
->ts
.type
!= BT_CLASS
5954 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5955 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5956 || (fsym
->ts
.type
== BT_CLASS
5957 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5958 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5960 if (fsym
->ts
.type
== BT_CLASS
)
5961 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5964 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5965 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5967 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5968 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5970 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5971 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5974 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5977 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5978 gfc_array_index_type
,
5979 fold_convert (gfc_array_index_type
, tmp2
),
5980 fold_convert (gfc_array_index_type
, tmp
));
5981 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5982 gfc_array_index_type
, offset
, tmp
);
5984 vec_safe_push (stringargs
, offset
);
5987 vec_safe_push (arglist
, parmse
.expr
);
5989 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5993 else if (sym
->ts
.type
== BT_CLASS
)
5994 ts
= CLASS_DATA (sym
)->ts
;
5998 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5999 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
6000 else if (ts
.type
== BT_CHARACTER
)
6002 if (ts
.u
.cl
->length
== NULL
)
6004 /* Assumed character length results are not allowed by C418 of the 2003
6005 standard and are trapped in resolve.c; except in the case of SPREAD
6006 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6007 we take the character length of the first argument for the result.
6008 For dummies, we have to look through the formal argument list for
6009 this function and use the character length found there.*/
6011 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
6012 else if (!sym
->attr
.dummy
)
6013 cl
.backend_decl
= (*stringargs
)[0];
6016 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
6017 for (; formal
; formal
= formal
->next
)
6018 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
6019 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
6021 len
= cl
.backend_decl
;
6027 /* Calculate the length of the returned string. */
6028 gfc_init_se (&parmse
, NULL
);
6029 if (need_interface_mapping
)
6030 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
6032 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
6033 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6034 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
6036 /* TODO: It would be better to have the charlens as
6037 gfc_charlen_type_node already when the interface is
6038 created instead of converting it here (see PR 84615). */
6039 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6040 gfc_charlen_type_node
,
6041 fold_convert (gfc_charlen_type_node
, tmp
),
6042 build_zero_cst (gfc_charlen_type_node
));
6043 cl
.backend_decl
= tmp
;
6046 /* Set up a charlen structure for it. */
6051 len
= cl
.backend_decl
;
6054 byref
= (comp
&& (comp
->attr
.dimension
6055 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
6056 || (!comp
&& gfc_return_by_reference (sym
));
6059 if (se
->direct_byref
)
6061 /* Sometimes, too much indirection can be applied; e.g. for
6062 function_result = array_valued_recursive_function. */
6063 if (TREE_TYPE (TREE_TYPE (se
->expr
))
6064 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
6065 && GFC_DESCRIPTOR_TYPE_P
6066 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
6067 se
->expr
= build_fold_indirect_ref_loc (input_location
,
6070 /* If the lhs of an assignment x = f(..) is allocatable and
6071 f2003 is allowed, we must do the automatic reallocation.
6072 TODO - deal with intrinsics, without using a temporary. */
6073 if (flag_realloc_lhs
6074 && se
->ss
&& se
->ss
->loop_chain
6075 && se
->ss
->loop_chain
->is_alloc_lhs
6076 && !expr
->value
.function
.isym
6077 && sym
->result
->as
!= NULL
)
6079 /* Evaluate the bounds of the result, if known. */
6080 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
6083 /* Perform the automatic reallocation. */
6084 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6086 gfc_add_expr_to_block (&se
->pre
, tmp
);
6088 /* Pass the temporary as the first argument. */
6089 result
= info
->descriptor
;
6092 result
= build_fold_indirect_ref_loc (input_location
,
6094 vec_safe_push (retargs
, se
->expr
);
6096 else if (comp
&& comp
->attr
.dimension
)
6098 gcc_assert (se
->loop
&& info
);
6100 /* Set the type of the array. */
6101 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6102 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6104 /* Evaluate the bounds of the result, if known. */
6105 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6107 /* If the lhs of an assignment x = f(..) is allocatable and
6108 f2003 is allowed, we must not generate the function call
6109 here but should just send back the results of the mapping.
6110 This is signalled by the function ss being flagged. */
6111 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6113 gfc_free_interface_mapping (&mapping
);
6114 return has_alternate_specifier
;
6117 /* Create a temporary to store the result. In case the function
6118 returns a pointer, the temporary will be a shallow copy and
6119 mustn't be deallocated. */
6120 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6121 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6122 tmp
, NULL_TREE
, false,
6123 !comp
->attr
.pointer
, callee_alloc
,
6124 &se
->ss
->info
->expr
->where
);
6126 /* Pass the temporary as the first argument. */
6127 result
= info
->descriptor
;
6128 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6129 vec_safe_push (retargs
, tmp
);
6131 else if (!comp
&& sym
->result
->attr
.dimension
)
6133 gcc_assert (se
->loop
&& info
);
6135 /* Set the type of the array. */
6136 tmp
= gfc_typenode_for_spec (&ts
);
6137 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6139 /* Evaluate the bounds of the result, if known. */
6140 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6142 /* If the lhs of an assignment x = f(..) is allocatable and
6143 f2003 is allowed, we must not generate the function call
6144 here but should just send back the results of the mapping.
6145 This is signalled by the function ss being flagged. */
6146 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6148 gfc_free_interface_mapping (&mapping
);
6149 return has_alternate_specifier
;
6152 /* Create a temporary to store the result. In case the function
6153 returns a pointer, the temporary will be a shallow copy and
6154 mustn't be deallocated. */
6155 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6156 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6157 tmp
, NULL_TREE
, false,
6158 !sym
->attr
.pointer
, callee_alloc
,
6159 &se
->ss
->info
->expr
->where
);
6161 /* Pass the temporary as the first argument. */
6162 result
= info
->descriptor
;
6163 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6164 vec_safe_push (retargs
, tmp
);
6166 else if (ts
.type
== BT_CHARACTER
)
6168 /* Pass the string length. */
6169 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6170 type
= build_pointer_type (type
);
6172 /* Emit a DECL_EXPR for the VLA type. */
6173 tmp
= TREE_TYPE (type
);
6175 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6177 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6178 DECL_ARTIFICIAL (tmp
) = 1;
6179 DECL_IGNORED_P (tmp
) = 1;
6180 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6181 TREE_TYPE (tmp
), tmp
);
6182 gfc_add_expr_to_block (&se
->pre
, tmp
);
6185 /* Return an address to a char[0:len-1]* temporary for
6186 character pointers. */
6187 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6188 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6190 var
= gfc_create_var (type
, "pstr");
6192 if ((!comp
&& sym
->attr
.allocatable
)
6193 || (comp
&& comp
->attr
.allocatable
))
6195 gfc_add_modify (&se
->pre
, var
,
6196 fold_convert (TREE_TYPE (var
),
6197 null_pointer_node
));
6198 tmp
= gfc_call_free (var
);
6199 gfc_add_expr_to_block (&se
->post
, tmp
);
6202 /* Provide an address expression for the function arguments. */
6203 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6206 var
= gfc_conv_string_tmp (se
, type
, len
);
6208 vec_safe_push (retargs
, var
);
6212 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6214 type
= gfc_get_complex_type (ts
.kind
);
6215 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6216 vec_safe_push (retargs
, var
);
6219 /* Add the string length to the argument list. */
6220 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6224 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6225 TREE_STATIC (tmp
) = 1;
6226 gfc_add_modify (&se
->pre
, tmp
,
6227 build_int_cst (TREE_TYPE (tmp
), 0));
6228 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6229 vec_safe_push (retargs
, tmp
);
6231 else if (ts
.type
== BT_CHARACTER
)
6232 vec_safe_push (retargs
, len
);
6234 gfc_free_interface_mapping (&mapping
);
6236 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6237 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6238 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6239 vec_safe_reserve (retargs
, arglen
);
6241 /* Add the return arguments. */
6242 vec_safe_splice (retargs
, arglist
);
6244 /* Add the hidden present status for optional+value to the arguments. */
6245 vec_safe_splice (retargs
, optionalargs
);
6247 /* Add the hidden string length parameters to the arguments. */
6248 vec_safe_splice (retargs
, stringargs
);
6250 /* We may want to append extra arguments here. This is used e.g. for
6251 calls to libgfortran_matmul_??, which need extra information. */
6252 vec_safe_splice (retargs
, append_args
);
6256 /* Generate the actual call. */
6257 if (base_object
== NULL_TREE
)
6258 conv_function_val (se
, sym
, expr
);
6260 conv_base_obj_fcn_val (se
, base_object
, expr
);
6262 /* If there are alternate return labels, function type should be
6263 integer. Can't modify the type in place though, since it can be shared
6264 with other functions. For dummy arguments, the typing is done to
6265 this result, even if it has to be repeated for each call. */
6266 if (has_alternate_specifier
6267 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6269 if (!sym
->attr
.dummy
)
6271 TREE_TYPE (sym
->backend_decl
)
6272 = build_function_type (integer_type_node
,
6273 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6274 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6277 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6280 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6281 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6283 /* Allocatable scalar function results must be freed and nullified
6284 after use. This necessitates the creation of a temporary to
6285 hold the result to prevent duplicate calls. */
6286 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6287 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6288 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6290 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6291 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6293 tmp
= gfc_call_free (tmp
);
6294 gfc_add_expr_to_block (&post
, tmp
);
6295 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6298 /* If we have a pointer function, but we don't want a pointer, e.g.
6301 where f is pointer valued, we have to dereference the result. */
6302 if (!se
->want_pointer
&& !byref
6303 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6304 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6305 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6307 /* f2c calling conventions require a scalar default real function to
6308 return a double precision result. Convert this back to default
6309 real. We only care about the cases that can happen in Fortran 77.
6311 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6312 && sym
->ts
.kind
== gfc_default_real_kind
6313 && !sym
->attr
.always_explicit
)
6314 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6316 /* A pure function may still have side-effects - it may modify its
6318 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6320 if (!sym
->attr
.pure
)
6321 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6326 /* Add the function call to the pre chain. There is no expression. */
6327 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6328 se
->expr
= NULL_TREE
;
6330 if (!se
->direct_byref
)
6332 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6334 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6336 /* Check the data pointer hasn't been modified. This would
6337 happen in a function returning a pointer. */
6338 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6339 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6342 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6345 se
->expr
= info
->descriptor
;
6346 /* Bundle in the string length. */
6347 se
->string_length
= len
;
6349 else if (ts
.type
== BT_CHARACTER
)
6351 /* Dereference for character pointer results. */
6352 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6353 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6354 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6358 se
->string_length
= len
;
6362 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6363 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6368 /* Associate the rhs class object's meta-data with the result, when the
6369 result is a temporary. */
6370 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6371 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6372 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6375 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6377 gfc_init_se (&parmse
, NULL
);
6378 parmse
.data_not_needed
= 1;
6379 gfc_conv_expr (&parmse
, class_expr
);
6380 if (!DECL_LANG_SPECIFIC (result
))
6381 gfc_allocate_lang_decl (result
);
6382 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6383 gfc_free_expr (class_expr
);
6384 gcc_assert (parmse
.pre
.head
== NULL_TREE
6385 && parmse
.post
.head
== NULL_TREE
);
6388 /* Follow the function call with the argument post block. */
6391 gfc_add_block_to_block (&se
->pre
, &post
);
6393 /* Transformational functions of derived types with allocatable
6394 components must have the result allocatable components copied when the
6395 argument is actually given. */
6396 arg
= expr
->value
.function
.actual
;
6397 if (result
&& arg
&& expr
->rank
6398 && expr
->value
.function
.isym
6399 && expr
->value
.function
.isym
->transformational
6401 && arg
->expr
->ts
.type
== BT_DERIVED
6402 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6405 /* Copy the allocatable components. We have to use a
6406 temporary here to prevent source allocatable components
6407 from being corrupted. */
6408 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6409 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6410 result
, tmp2
, expr
->rank
, 0);
6411 gfc_add_expr_to_block (&se
->pre
, tmp
);
6412 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6414 gfc_add_expr_to_block (&se
->pre
, tmp
);
6416 /* Finally free the temporary's data field. */
6417 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6418 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6419 NULL_TREE
, NULL_TREE
, true,
6420 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6421 gfc_add_expr_to_block (&se
->pre
, tmp
);
6426 /* For a function with a class array result, save the result as
6427 a temporary, set the info fields needed by the scalarizer and
6428 call the finalization function of the temporary. Note that the
6429 nullification of allocatable components needed by the result
6430 is done in gfc_trans_assignment_1. */
6431 if (expr
&& ((gfc_is_class_array_function (expr
)
6432 && se
->ss
&& se
->ss
->loop
)
6433 || gfc_is_alloc_class_scalar_function (expr
))
6434 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6435 && expr
->must_finalize
)
6440 if (se
->ss
&& se
->ss
->loop
)
6442 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
6443 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6444 tmp
= gfc_class_data_get (se
->expr
);
6445 info
->descriptor
= tmp
;
6446 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6447 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6448 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6450 tree dim
= gfc_rank_cst
[n
];
6451 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6452 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6457 /* TODO Eliminate the doubling of temporaries. This
6458 one is necessary to ensure no memory leakage. */
6459 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6460 tmp
= gfc_class_data_get (se
->expr
);
6461 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6462 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6465 if ((gfc_is_class_array_function (expr
)
6466 || gfc_is_alloc_class_scalar_function (expr
))
6467 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
6468 goto no_finalization
;
6470 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6471 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6474 fold_convert (TREE_TYPE (final_fndecl
),
6475 null_pointer_node
));
6476 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6478 tmp
= build_call_expr_loc (input_location
,
6480 gfc_build_addr_expr (NULL
, tmp
),
6481 gfc_class_vtab_size_get (se
->expr
),
6482 boolean_false_node
);
6483 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6484 void_type_node
, is_final
, tmp
,
6485 build_empty_stmt (input_location
));
6487 if (se
->ss
&& se
->ss
->loop
)
6489 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6490 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6493 fold_convert (TREE_TYPE (info
->data
),
6494 null_pointer_node
));
6495 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6496 void_type_node
, tmp
,
6497 gfc_call_free (info
->data
),
6498 build_empty_stmt (input_location
));
6499 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6504 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6505 classdata
= gfc_class_data_get (se
->expr
);
6506 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6509 fold_convert (TREE_TYPE (classdata
),
6510 null_pointer_node
));
6511 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6512 void_type_node
, tmp
,
6513 gfc_call_free (classdata
),
6514 build_empty_stmt (input_location
));
6515 gfc_add_expr_to_block (&se
->post
, tmp
);
6520 gfc_add_block_to_block (&se
->post
, &post
);
6523 return has_alternate_specifier
;
6527 /* Fill a character string with spaces. */
6530 fill_with_spaces (tree start
, tree type
, tree size
)
6532 stmtblock_t block
, loop
;
6533 tree i
, el
, exit_label
, cond
, tmp
;
6535 /* For a simple char type, we can call memset(). */
6536 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6537 return build_call_expr_loc (input_location
,
6538 builtin_decl_explicit (BUILT_IN_MEMSET
),
6540 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6541 lang_hooks
.to_target_charset (' ')),
6542 fold_convert (size_type_node
, size
));
6544 /* Otherwise, we use a loop:
6545 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6549 /* Initialize variables. */
6550 gfc_init_block (&block
);
6551 i
= gfc_create_var (sizetype
, "i");
6552 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6553 el
= gfc_create_var (build_pointer_type (type
), "el");
6554 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6555 exit_label
= gfc_build_label_decl (NULL_TREE
);
6556 TREE_USED (exit_label
) = 1;
6560 gfc_init_block (&loop
);
6562 /* Exit condition. */
6563 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6564 build_zero_cst (sizetype
));
6565 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6566 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6567 build_empty_stmt (input_location
));
6568 gfc_add_expr_to_block (&loop
, tmp
);
6571 gfc_add_modify (&loop
,
6572 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6573 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6575 /* Increment loop variables. */
6576 gfc_add_modify (&loop
, i
,
6577 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6578 TYPE_SIZE_UNIT (type
)));
6579 gfc_add_modify (&loop
, el
,
6580 fold_build_pointer_plus_loc (input_location
,
6581 el
, TYPE_SIZE_UNIT (type
)));
6583 /* Making the loop... actually loop! */
6584 tmp
= gfc_finish_block (&loop
);
6585 tmp
= build1_v (LOOP_EXPR
, tmp
);
6586 gfc_add_expr_to_block (&block
, tmp
);
6588 /* The exit label. */
6589 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6590 gfc_add_expr_to_block (&block
, tmp
);
6593 return gfc_finish_block (&block
);
6597 /* Generate code to copy a string. */
6600 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6601 int dkind
, tree slength
, tree src
, int skind
)
6603 tree tmp
, dlen
, slen
;
6612 stmtblock_t tempblock
;
6614 gcc_assert (dkind
== skind
);
6616 if (slength
!= NULL_TREE
)
6618 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
6619 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6623 slen
= build_one_cst (gfc_charlen_type_node
);
6627 if (dlength
!= NULL_TREE
)
6629 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
6630 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6634 dlen
= build_one_cst (gfc_charlen_type_node
);
6638 /* Assign directly if the types are compatible. */
6639 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6640 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6642 gfc_add_modify (block
, dsc
, ssc
);
6646 /* The string copy algorithm below generates code like
6650 if (srclen < destlen)
6652 memmove (dest, src, srclen);
6654 memset (&dest[srclen], ' ', destlen - srclen);
6658 // Truncate if too long.
6659 memmove (dest, src, destlen);
6664 /* Do nothing if the destination length is zero. */
6665 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6666 build_zero_cst (TREE_TYPE (dlen
)));
6668 /* For non-default character kinds, we have to multiply the string
6669 length by the base type size. */
6670 chartype
= gfc_get_char_type (dkind
);
6671 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
6673 fold_convert (TREE_TYPE (slen
),
6674 TYPE_SIZE_UNIT (chartype
)));
6675 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
6677 fold_convert (TREE_TYPE (dlen
),
6678 TYPE_SIZE_UNIT (chartype
)));
6680 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6681 dest
= fold_convert (pvoid_type_node
, dest
);
6683 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6685 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6686 src
= fold_convert (pvoid_type_node
, src
);
6688 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6690 /* Truncate string if source is too long. */
6691 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6694 /* Copy and pad with spaces. */
6695 tmp3
= build_call_expr_loc (input_location
,
6696 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6698 fold_convert (size_type_node
, slen
));
6700 /* Wstringop-overflow appears at -O3 even though this warning is not
6701 explicitly available in fortran nor can it be switched off. If the
6702 source length is a constant, its negative appears as a very large
6703 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6704 the result of the MINUS_EXPR suppresses this spurious warning. */
6705 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6706 TREE_TYPE(dlen
), dlen
, slen
);
6707 if (slength
&& TREE_CONSTANT (slength
))
6708 tmp
= gfc_evaluate_now (tmp
, block
);
6710 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6711 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6713 gfc_init_block (&tempblock
);
6714 gfc_add_expr_to_block (&tempblock
, tmp3
);
6715 gfc_add_expr_to_block (&tempblock
, tmp4
);
6716 tmp3
= gfc_finish_block (&tempblock
);
6718 /* The truncated memmove if the slen >= dlen. */
6719 tmp2
= build_call_expr_loc (input_location
,
6720 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6722 fold_convert (size_type_node
, dlen
));
6724 /* The whole copy_string function is there. */
6725 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6727 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6728 build_empty_stmt (input_location
));
6729 gfc_add_expr_to_block (block
, tmp
);
6733 /* Translate a statement function.
6734 The value of a statement function reference is obtained by evaluating the
6735 expression using the values of the actual arguments for the values of the
6736 corresponding dummy arguments. */
6739 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6743 gfc_formal_arglist
*fargs
;
6744 gfc_actual_arglist
*args
;
6747 gfc_saved_var
*saved_vars
;
6753 sym
= expr
->symtree
->n
.sym
;
6754 args
= expr
->value
.function
.actual
;
6755 gfc_init_se (&lse
, NULL
);
6756 gfc_init_se (&rse
, NULL
);
6759 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6761 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6762 temp_vars
= XCNEWVEC (tree
, n
);
6764 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6765 fargs
= fargs
->next
, n
++)
6767 /* Each dummy shall be specified, explicitly or implicitly, to be
6769 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6772 if (fsym
->ts
.type
== BT_CHARACTER
)
6774 /* Copy string arguments. */
6777 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6778 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6780 /* Create a temporary to hold the value. */
6781 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6782 fsym
->ts
.u
.cl
->backend_decl
6783 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6785 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6786 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6788 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6790 gfc_conv_expr (&rse
, args
->expr
);
6791 gfc_conv_string_parameter (&rse
);
6792 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6793 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6795 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6796 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6797 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6798 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6802 /* For everything else, just evaluate the expression. */
6804 /* Create a temporary to hold the value. */
6805 type
= gfc_typenode_for_spec (&fsym
->ts
);
6806 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6808 gfc_conv_expr (&lse
, args
->expr
);
6810 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6811 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6812 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6818 /* Use the temporary variables in place of the real ones. */
6819 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6820 fargs
= fargs
->next
, n
++)
6821 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6823 gfc_conv_expr (se
, sym
->value
);
6825 if (sym
->ts
.type
== BT_CHARACTER
)
6827 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6829 /* Force the expression to the correct length. */
6830 if (!INTEGER_CST_P (se
->string_length
)
6831 || tree_int_cst_lt (se
->string_length
,
6832 sym
->ts
.u
.cl
->backend_decl
))
6834 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6835 tmp
= gfc_create_var (type
, sym
->name
);
6836 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6837 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6838 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6842 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6845 /* Restore the original variables. */
6846 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6847 fargs
= fargs
->next
, n
++)
6848 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6854 /* Translate a function expression. */
6857 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6861 if (expr
->value
.function
.isym
)
6863 gfc_conv_intrinsic_function (se
, expr
);
6867 /* expr.value.function.esym is the resolved (specific) function symbol for
6868 most functions. However this isn't set for dummy procedures. */
6869 sym
= expr
->value
.function
.esym
;
6871 sym
= expr
->symtree
->n
.sym
;
6873 /* The IEEE_ARITHMETIC functions are caught here. */
6874 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6875 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6878 /* We distinguish statement functions from general functions to improve
6879 runtime performance. */
6880 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6882 gfc_conv_statement_function (se
, expr
);
6886 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6891 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6894 is_zero_initializer_p (gfc_expr
* expr
)
6896 if (expr
->expr_type
!= EXPR_CONSTANT
)
6899 /* We ignore constants with prescribed memory representations for now. */
6900 if (expr
->representation
.string
)
6903 switch (expr
->ts
.type
)
6906 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6909 return mpfr_zero_p (expr
->value
.real
)
6910 && MPFR_SIGN (expr
->value
.real
) >= 0;
6913 return expr
->value
.logical
== 0;
6916 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6917 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6918 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6919 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6929 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6934 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6935 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6937 gfc_conv_tmp_array_ref (se
);
6941 /* Build a static initializer. EXPR is the expression for the initial value.
6942 The other parameters describe the variable of the component being
6943 initialized. EXPR may be null. */
6946 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6947 bool array
, bool pointer
, bool procptr
)
6951 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6952 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6953 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6954 return build_constructor (type
, NULL
);
6956 if (!(expr
|| pointer
|| procptr
))
6959 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6960 (these are the only two iso_c_binding derived types that can be
6961 used as initialization expressions). If so, we need to modify
6962 the 'expr' to be that for a (void *). */
6963 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6964 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6966 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6968 /* The derived symbol has already been converted to a (void *). Use
6970 if (derived
->ts
.kind
== 0)
6971 derived
->ts
.kind
= gfc_default_integer_kind
;
6972 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6973 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6975 gfc_init_se (&se
, NULL
);
6976 gfc_conv_constant (&se
, expr
);
6977 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6981 if (array
&& !procptr
)
6984 /* Arrays need special handling. */
6986 ctor
= gfc_build_null_descriptor (type
);
6987 /* Special case assigning an array to zero. */
6988 else if (is_zero_initializer_p (expr
))
6989 ctor
= build_constructor (type
, NULL
);
6991 ctor
= gfc_conv_array_initializer (type
, expr
);
6992 TREE_STATIC (ctor
) = 1;
6995 else if (pointer
|| procptr
)
6997 if (ts
->type
== BT_CLASS
&& !procptr
)
6999 gfc_init_se (&se
, NULL
);
7000 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7001 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7002 TREE_STATIC (se
.expr
) = 1;
7005 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
7006 return fold_convert (type
, null_pointer_node
);
7009 gfc_init_se (&se
, NULL
);
7010 se
.want_pointer
= 1;
7011 gfc_conv_expr (&se
, expr
);
7012 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7022 gfc_init_se (&se
, NULL
);
7023 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7024 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
7026 gfc_conv_structure (&se
, expr
, 1);
7027 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
7028 TREE_STATIC (se
.expr
) = 1;
7033 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
7034 TREE_STATIC (ctor
) = 1;
7039 gfc_init_se (&se
, NULL
);
7040 gfc_conv_constant (&se
, expr
);
7041 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
7048 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
7054 gfc_array_info
*lss_array
;
7061 gfc_start_block (&block
);
7063 /* Initialize the scalarizer. */
7064 gfc_init_loopinfo (&loop
);
7066 gfc_init_se (&lse
, NULL
);
7067 gfc_init_se (&rse
, NULL
);
7070 rss
= gfc_walk_expr (expr
);
7071 if (rss
== gfc_ss_terminator
)
7072 /* The rhs is scalar. Add a ss for the expression. */
7073 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
7075 /* Create a SS for the destination. */
7076 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
7078 lss_array
= &lss
->info
->data
.array
;
7079 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
7080 lss_array
->descriptor
= dest
;
7081 lss_array
->data
= gfc_conv_array_data (dest
);
7082 lss_array
->offset
= gfc_conv_array_offset (dest
);
7083 for (n
= 0; n
< cm
->as
->rank
; n
++)
7085 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
7086 lss_array
->stride
[n
] = gfc_index_one_node
;
7088 mpz_init (lss_array
->shape
[n
]);
7089 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
7090 cm
->as
->lower
[n
]->value
.integer
);
7091 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
7094 /* Associate the SS with the loop. */
7095 gfc_add_ss_to_loop (&loop
, lss
);
7096 gfc_add_ss_to_loop (&loop
, rss
);
7098 /* Calculate the bounds of the scalarization. */
7099 gfc_conv_ss_startstride (&loop
);
7101 /* Setup the scalarizing loops. */
7102 gfc_conv_loop_setup (&loop
, &expr
->where
);
7104 /* Setup the gfc_se structures. */
7105 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7106 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7109 gfc_mark_ss_chain_used (rss
, 1);
7111 gfc_mark_ss_chain_used (lss
, 1);
7113 /* Start the scalarized loop body. */
7114 gfc_start_scalarized_body (&loop
, &body
);
7116 gfc_conv_tmp_array_ref (&lse
);
7117 if (cm
->ts
.type
== BT_CHARACTER
)
7118 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7120 gfc_conv_expr (&rse
, expr
);
7122 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7123 gfc_add_expr_to_block (&body
, tmp
);
7125 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7127 /* Generate the copying loops. */
7128 gfc_trans_scalarizing_loops (&loop
, &body
);
7130 /* Wrap the whole thing up. */
7131 gfc_add_block_to_block (&block
, &loop
.pre
);
7132 gfc_add_block_to_block (&block
, &loop
.post
);
7134 gcc_assert (lss_array
->shape
!= NULL
);
7135 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7136 gfc_cleanup_loop (&loop
);
7138 return gfc_finish_block (&block
);
7143 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7153 gfc_expr
*arg
= NULL
;
7155 gfc_start_block (&block
);
7156 gfc_init_se (&se
, NULL
);
7158 /* Get the descriptor for the expressions. */
7159 se
.want_pointer
= 0;
7160 gfc_conv_expr_descriptor (&se
, expr
);
7161 gfc_add_block_to_block (&block
, &se
.pre
);
7162 gfc_add_modify (&block
, dest
, se
.expr
);
7164 /* Deal with arrays of derived types with allocatable components. */
7165 if (gfc_bt_struct (cm
->ts
.type
)
7166 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7167 // TODO: Fix caf_mode
7168 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7171 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7172 && CLASS_DATA(cm
)->attr
.allocatable
)
7174 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7175 // TODO: Fix caf_mode
7176 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7181 tmp
= TREE_TYPE (dest
);
7182 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7183 tmp
, expr
->rank
, NULL_TREE
);
7187 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7188 TREE_TYPE(cm
->backend_decl
),
7189 cm
->as
->rank
, NULL_TREE
);
7191 gfc_add_expr_to_block (&block
, tmp
);
7192 gfc_add_block_to_block (&block
, &se
.post
);
7194 if (expr
->expr_type
!= EXPR_VARIABLE
)
7195 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7198 /* We need to know if the argument of a conversion function is a
7199 variable, so that the correct lower bound can be used. */
7200 if (expr
->expr_type
== EXPR_FUNCTION
7201 && expr
->value
.function
.isym
7202 && expr
->value
.function
.isym
->conversion
7203 && expr
->value
.function
.actual
->expr
7204 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7205 arg
= expr
->value
.function
.actual
->expr
;
7207 /* Obtain the array spec of full array references. */
7209 as
= gfc_get_full_arrayspec_from_expr (arg
);
7211 as
= gfc_get_full_arrayspec_from_expr (expr
);
7213 /* Shift the lbound and ubound of temporaries to being unity,
7214 rather than zero, based. Always calculate the offset. */
7215 offset
= gfc_conv_descriptor_offset_get (dest
);
7216 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7217 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7219 for (n
= 0; n
< expr
->rank
; n
++)
7224 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7225 TODO It looks as if gfc_conv_expr_descriptor should return
7226 the correct bounds and that the following should not be
7227 necessary. This would simplify gfc_conv_intrinsic_bound
7229 if (as
&& as
->lower
[n
])
7232 gfc_init_se (&lbse
, NULL
);
7233 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7234 gfc_add_block_to_block (&block
, &lbse
.pre
);
7235 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7239 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7240 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7244 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7247 lbound
= gfc_index_one_node
;
7249 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7251 /* Shift the bounds and set the offset accordingly. */
7252 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7253 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7254 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7255 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7257 gfc_conv_descriptor_ubound_set (&block
, dest
,
7258 gfc_rank_cst
[n
], tmp
);
7259 gfc_conv_descriptor_lbound_set (&block
, dest
,
7260 gfc_rank_cst
[n
], lbound
);
7262 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7263 gfc_conv_descriptor_lbound_get (dest
,
7265 gfc_conv_descriptor_stride_get (dest
,
7267 gfc_add_modify (&block
, tmp2
, tmp
);
7268 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7270 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7275 /* If a conversion expression has a null data pointer
7276 argument, nullify the allocatable component. */
7280 if (arg
->symtree
->n
.sym
->attr
.allocatable
7281 || arg
->symtree
->n
.sym
->attr
.pointer
)
7283 non_null_expr
= gfc_finish_block (&block
);
7284 gfc_start_block (&block
);
7285 gfc_conv_descriptor_data_set (&block
, dest
,
7287 null_expr
= gfc_finish_block (&block
);
7288 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7289 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7290 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7291 return build3_v (COND_EXPR
, tmp
,
7292 null_expr
, non_null_expr
);
7296 return gfc_finish_block (&block
);
7300 /* Allocate or reallocate scalar component, as necessary. */
7303 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7313 tree lhs_cl_size
= NULL_TREE
;
7318 if (!expr2
|| expr2
->rank
)
7321 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7323 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7325 char name
[GFC_MAX_SYMBOL_LEN
+9];
7326 gfc_component
*strlen
;
7327 /* Use the rhs string length and the lhs element size. */
7328 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7329 if (!expr2
->ts
.u
.cl
->backend_decl
)
7331 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7332 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7335 size
= expr2
->ts
.u
.cl
->backend_decl
;
7337 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7339 sprintf (name
, "_%s_length", cm
->name
);
7340 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7341 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7342 gfc_charlen_type_node
,
7343 TREE_OPERAND (comp
, 0),
7344 strlen
->backend_decl
, NULL_TREE
);
7346 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7347 tmp
= TYPE_SIZE_UNIT (tmp
);
7348 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7349 TREE_TYPE (tmp
), tmp
,
7350 fold_convert (TREE_TYPE (tmp
), size
));
7352 else if (cm
->ts
.type
== BT_CLASS
)
7354 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7355 if (expr2
->ts
.type
== BT_DERIVED
)
7357 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7358 size
= TYPE_SIZE_UNIT (tmp
);
7364 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7365 gfc_add_vptr_component (e2vtab
);
7366 gfc_add_size_component (e2vtab
);
7367 gfc_init_se (&se
, NULL
);
7368 gfc_conv_expr (&se
, e2vtab
);
7369 gfc_add_block_to_block (block
, &se
.pre
);
7370 size
= fold_convert (size_type_node
, se
.expr
);
7371 gfc_free_expr (e2vtab
);
7373 size_in_bytes
= size
;
7377 /* Otherwise use the length in bytes of the rhs. */
7378 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7379 size_in_bytes
= size
;
7382 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7383 size_in_bytes
, size_one_node
);
7385 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7387 tmp
= build_call_expr_loc (input_location
,
7388 builtin_decl_explicit (BUILT_IN_CALLOC
),
7389 2, build_one_cst (size_type_node
),
7391 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7392 gfc_add_modify (block
, comp
, tmp
);
7396 tmp
= build_call_expr_loc (input_location
,
7397 builtin_decl_explicit (BUILT_IN_MALLOC
),
7399 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7400 ptr
= gfc_class_data_get (comp
);
7403 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7404 gfc_add_modify (block
, ptr
, tmp
);
7407 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7408 /* Update the lhs character length. */
7409 gfc_add_modify (block
, lhs_cl_size
,
7410 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
7414 /* Assign a single component of a derived type constructor. */
7417 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7418 gfc_symbol
*sym
, bool init
)
7426 gfc_start_block (&block
);
7428 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7430 /* Only care about pointers here, not about allocatables. */
7431 gfc_init_se (&se
, NULL
);
7432 /* Pointer component. */
7433 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7434 && !cm
->attr
.proc_pointer
)
7436 /* Array pointer. */
7437 if (expr
->expr_type
== EXPR_NULL
)
7438 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7441 se
.direct_byref
= 1;
7443 gfc_conv_expr_descriptor (&se
, expr
);
7444 gfc_add_block_to_block (&block
, &se
.pre
);
7445 gfc_add_block_to_block (&block
, &se
.post
);
7450 /* Scalar pointers. */
7451 se
.want_pointer
= 1;
7452 gfc_conv_expr (&se
, expr
);
7453 gfc_add_block_to_block (&block
, &se
.pre
);
7455 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7456 && expr
->symtree
->n
.sym
->attr
.dummy
)
7457 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7459 gfc_add_modify (&block
, dest
,
7460 fold_convert (TREE_TYPE (dest
), se
.expr
));
7461 gfc_add_block_to_block (&block
, &se
.post
);
7464 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7466 /* NULL initialization for CLASS components. */
7467 tmp
= gfc_trans_structure_assign (dest
,
7468 gfc_class_initializer (&cm
->ts
, expr
),
7470 gfc_add_expr_to_block (&block
, tmp
);
7472 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7473 && !cm
->attr
.proc_pointer
)
7475 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7476 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7477 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7479 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7480 gfc_add_expr_to_block (&block
, tmp
);
7484 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7485 gfc_add_expr_to_block (&block
, tmp
);
7488 else if (cm
->ts
.type
== BT_CLASS
7489 && CLASS_DATA (cm
)->attr
.dimension
7490 && CLASS_DATA (cm
)->attr
.allocatable
7491 && expr
->ts
.type
== BT_DERIVED
)
7493 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7494 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7495 tmp
= gfc_class_vptr_get (dest
);
7496 gfc_add_modify (&block
, tmp
,
7497 fold_convert (TREE_TYPE (tmp
), vtab
));
7498 tmp
= gfc_class_data_get (dest
);
7499 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7500 gfc_add_expr_to_block (&block
, tmp
);
7502 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7504 /* NULL initialization for allocatable components. */
7505 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7506 null_pointer_node
));
7508 else if (init
&& (cm
->attr
.allocatable
7509 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7510 && expr
->ts
.type
!= BT_CLASS
)))
7512 /* Take care about non-array allocatable components here. The alloc_*
7513 routine below is motivated by the alloc_scalar_allocatable_for_
7514 assignment() routine, but with the realloc portions removed and
7516 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7521 /* The remainder of these instructions follow the if (cm->attr.pointer)
7522 if (!cm->attr.dimension) part above. */
7523 gfc_init_se (&se
, NULL
);
7524 gfc_conv_expr (&se
, expr
);
7525 gfc_add_block_to_block (&block
, &se
.pre
);
7527 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7528 && expr
->symtree
->n
.sym
->attr
.dummy
)
7529 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7531 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7533 tmp
= gfc_class_data_get (dest
);
7534 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7535 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7536 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7537 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7538 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7541 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7543 /* For deferred strings insert a memcpy. */
7544 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7547 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7548 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7550 : expr
->ts
.u
.cl
->backend_decl
);
7551 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7552 gfc_add_expr_to_block (&block
, tmp
);
7555 gfc_add_modify (&block
, tmp
,
7556 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7557 gfc_add_block_to_block (&block
, &se
.post
);
7559 else if (expr
->ts
.type
== BT_UNION
)
7562 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7563 /* We mark that the entire union should be initialized with a contrived
7564 EXPR_NULL expression at the beginning. */
7565 if (c
!= NULL
&& c
->n
.component
== NULL
7566 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7568 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7569 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7570 gfc_add_expr_to_block (&block
, tmp
);
7571 c
= gfc_constructor_next (c
);
7573 /* The following constructor expression, if any, represents a specific
7574 map intializer, as given by the user. */
7575 if (c
!= NULL
&& c
->expr
!= NULL
)
7577 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7578 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7579 gfc_add_expr_to_block (&block
, tmp
);
7582 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7584 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7586 tree dealloc
= NULL_TREE
;
7587 gfc_init_se (&se
, NULL
);
7588 gfc_conv_expr (&se
, expr
);
7589 gfc_add_block_to_block (&block
, &se
.pre
);
7590 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7591 expression in a temporary variable and deallocate the allocatable
7592 components. Then we can the copy the expression to the result. */
7593 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7594 && expr
->expr_type
!= EXPR_VARIABLE
)
7596 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7597 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7600 gfc_add_modify (&block
, dest
,
7601 fold_convert (TREE_TYPE (dest
), se
.expr
));
7602 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7603 && expr
->expr_type
!= EXPR_NULL
)
7605 // TODO: Fix caf_mode
7606 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7607 dest
, expr
->rank
, 0);
7608 gfc_add_expr_to_block (&block
, tmp
);
7609 if (dealloc
!= NULL_TREE
)
7610 gfc_add_expr_to_block (&block
, dealloc
);
7612 gfc_add_block_to_block (&block
, &se
.post
);
7616 /* Nested constructors. */
7617 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7618 gfc_add_expr_to_block (&block
, tmp
);
7621 else if (gfc_deferred_strlen (cm
, &tmp
))
7625 gcc_assert (strlen
);
7626 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7628 TREE_OPERAND (dest
, 0),
7631 if (expr
->expr_type
== EXPR_NULL
)
7633 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7634 gfc_add_modify (&block
, dest
, tmp
);
7635 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7636 gfc_add_modify (&block
, strlen
, tmp
);
7641 gfc_init_se (&se
, NULL
);
7642 gfc_conv_expr (&se
, expr
);
7643 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7644 tmp
= build_call_expr_loc (input_location
,
7645 builtin_decl_explicit (BUILT_IN_MALLOC
),
7647 gfc_add_modify (&block
, dest
,
7648 fold_convert (TREE_TYPE (dest
), tmp
));
7649 gfc_add_modify (&block
, strlen
,
7650 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
7651 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7652 gfc_add_expr_to_block (&block
, tmp
);
7655 else if (!cm
->attr
.artificial
)
7657 /* Scalar component (excluding deferred parameters). */
7658 gfc_init_se (&se
, NULL
);
7659 gfc_init_se (&lse
, NULL
);
7661 gfc_conv_expr (&se
, expr
);
7662 if (cm
->ts
.type
== BT_CHARACTER
)
7663 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7665 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7666 gfc_add_expr_to_block (&block
, tmp
);
7668 return gfc_finish_block (&block
);
7671 /* Assign a derived type constructor to a variable. */
7674 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7683 gfc_start_block (&block
);
7684 cm
= expr
->ts
.u
.derived
->components
;
7686 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7687 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7688 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7692 gfc_init_se (&se
, NULL
);
7693 gfc_init_se (&lse
, NULL
);
7694 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7696 gfc_add_modify (&block
, lse
.expr
,
7697 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7699 return gfc_finish_block (&block
);
7703 gfc_init_se (&se
, NULL
);
7705 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7706 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7708 /* Skip absent members in default initializers. */
7709 if (!c
->expr
&& !cm
->attr
.allocatable
)
7712 /* Register the component with the caf-lib before it is initialized.
7713 Register only allocatable components, that are not coarray'ed
7714 components (%comp[*]). Only register when the constructor is not the
7716 if (coarray
&& !cm
->attr
.codimension
7717 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7718 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7720 tree token
, desc
, size
;
7721 bool is_array
= cm
->ts
.type
== BT_CLASS
7722 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7724 field
= cm
->backend_decl
;
7725 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7726 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7727 if (cm
->ts
.type
== BT_CLASS
)
7728 field
= gfc_class_data_get (field
);
7730 token
= is_array
? gfc_conv_descriptor_token (field
)
7731 : fold_build3_loc (input_location
, COMPONENT_REF
,
7732 TREE_TYPE (cm
->caf_token
), dest
,
7733 cm
->caf_token
, NULL_TREE
);
7737 /* The _caf_register routine looks at the rank of the array
7738 descriptor to decide whether the data registered is an array
7740 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7742 /* When the rank is not known just set a positive rank, which
7743 suffices to recognize the data as array. */
7746 size
= build_zero_cst (size_type_node
);
7748 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
7749 build_int_cst (signed_char_type_node
, rank
));
7753 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
7754 cm
->ts
.type
== BT_CLASS
7755 ? CLASS_DATA (cm
)->attr
7757 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7759 gfc_add_block_to_block (&block
, &se
.pre
);
7760 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7761 7, size
, build_int_cst (
7763 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7764 gfc_build_addr_expr (pvoid_type_node
,
7766 gfc_build_addr_expr (NULL_TREE
, desc
),
7767 null_pointer_node
, null_pointer_node
,
7769 gfc_add_expr_to_block (&block
, tmp
);
7771 field
= cm
->backend_decl
;
7772 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7773 dest
, field
, NULL_TREE
);
7776 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7777 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7782 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7783 expr
->ts
.u
.derived
, init
);
7784 gfc_add_expr_to_block (&block
, tmp
);
7786 return gfc_finish_block (&block
);
7790 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7791 gfc_component
*un
, gfc_expr
*init
)
7793 gfc_constructor
*ctor
;
7795 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7798 ctor
= gfc_constructor_first (init
->value
.constructor
);
7800 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7803 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7805 /* If we have an 'initialize all' constructor, do it first. */
7806 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7808 tree union_type
= TREE_TYPE (un
->backend_decl
);
7809 tree val
= build_constructor (union_type
, NULL
);
7810 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7811 ctor
= gfc_constructor_next (ctor
);
7814 /* Add the map initializer on top. */
7815 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7817 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7818 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7819 TREE_TYPE (un
->backend_decl
),
7820 un
->attr
.dimension
, un
->attr
.pointer
,
7821 un
->attr
.proc_pointer
);
7822 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7826 /* Build an expression for a constructor. If init is nonzero then
7827 this is part of a static variable initializer. */
7830 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7837 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7839 gcc_assert (se
->ss
== NULL
);
7840 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7841 type
= gfc_typenode_for_spec (&expr
->ts
);
7845 /* Create a temporary variable and fill it in. */
7846 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7847 /* The symtree in expr is NULL, if the code to generate is for
7848 initializing the static members only. */
7849 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7851 gfc_add_expr_to_block (&se
->pre
, tmp
);
7855 cm
= expr
->ts
.u
.derived
->components
;
7857 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7858 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7860 /* Skip absent members in default initializers and allocatable
7861 components. Although the latter have a default initializer
7862 of EXPR_NULL,... by default, the static nullify is not needed
7863 since this is done every time we come into scope. */
7864 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7867 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7868 && strcmp (cm
->name
, "_extends") == 0
7869 && cm
->initializer
->symtree
)
7873 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7874 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7875 vtab
= unshare_expr_without_location (vtab
);
7876 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7878 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7880 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7881 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7882 fold_convert (TREE_TYPE (cm
->backend_decl
),
7885 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7886 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7887 fold_convert (TREE_TYPE (cm
->backend_decl
),
7888 integer_zero_node
));
7889 else if (cm
->ts
.type
== BT_UNION
)
7890 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7893 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7894 TREE_TYPE (cm
->backend_decl
),
7895 cm
->attr
.dimension
, cm
->attr
.pointer
,
7896 cm
->attr
.proc_pointer
);
7897 val
= unshare_expr_without_location (val
);
7899 /* Append it to the constructor list. */
7900 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7904 se
->expr
= build_constructor (type
, v
);
7906 TREE_CONSTANT (se
->expr
) = 1;
7910 /* Translate a substring expression. */
7913 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7919 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7921 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7922 expr
->value
.character
.length
,
7923 expr
->value
.character
.string
);
7925 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7926 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7929 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7933 /* Entry point for expression translation. Evaluates a scalar quantity.
7934 EXPR is the expression to be translated, and SE is the state structure if
7935 called from within the scalarized. */
7938 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7943 if (ss
&& ss
->info
->expr
== expr
7944 && (ss
->info
->type
== GFC_SS_SCALAR
7945 || ss
->info
->type
== GFC_SS_REFERENCE
))
7947 gfc_ss_info
*ss_info
;
7950 /* Substitute a scalar expression evaluated outside the scalarization
7952 se
->expr
= ss_info
->data
.scalar
.value
;
7953 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7954 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7956 se
->string_length
= ss_info
->string_length
;
7957 gfc_advance_se_ss_chain (se
);
7961 /* We need to convert the expressions for the iso_c_binding derived types.
7962 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7963 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7964 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7965 updated to be an integer with a kind equal to the size of a (void *). */
7966 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7967 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7969 if (expr
->expr_type
== EXPR_VARIABLE
7970 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7971 || expr
->symtree
->n
.sym
->intmod_sym_id
7972 == ISOCBINDING_NULL_FUNPTR
))
7974 /* Set expr_type to EXPR_NULL, which will result in
7975 null_pointer_node being used below. */
7976 expr
->expr_type
= EXPR_NULL
;
7980 /* Update the type/kind of the expression to be what the new
7981 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7982 expr
->ts
.type
= BT_INTEGER
;
7983 expr
->ts
.f90_type
= BT_VOID
;
7984 expr
->ts
.kind
= gfc_index_integer_kind
;
7988 gfc_fix_class_refs (expr
);
7990 switch (expr
->expr_type
)
7993 gfc_conv_expr_op (se
, expr
);
7997 gfc_conv_function_expr (se
, expr
);
8001 gfc_conv_constant (se
, expr
);
8005 gfc_conv_variable (se
, expr
);
8009 se
->expr
= null_pointer_node
;
8012 case EXPR_SUBSTRING
:
8013 gfc_conv_substring_expr (se
, expr
);
8016 case EXPR_STRUCTURE
:
8017 gfc_conv_structure (se
, expr
, 0);
8021 gfc_conv_array_constructor_expr (se
, expr
);
8030 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8031 of an assignment. */
8033 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
8035 gfc_conv_expr (se
, expr
);
8036 /* All numeric lvalues should have empty post chains. If not we need to
8037 figure out a way of rewriting an lvalue so that it has no post chain. */
8038 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
8041 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8042 numeric expressions. Used for scalar values where inserting cleanup code
8045 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
8049 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
8050 gfc_conv_expr (se
, expr
);
8053 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8054 gfc_add_modify (&se
->pre
, val
, se
->expr
);
8056 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8060 /* Helper to translate an expression and convert it to a particular type. */
8062 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
8064 gfc_conv_expr_val (se
, expr
);
8065 se
->expr
= convert (type
, se
->expr
);
8069 /* Converts an expression so that it can be passed by reference. Scalar
8073 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
8079 if (ss
&& ss
->info
->expr
== expr
8080 && ss
->info
->type
== GFC_SS_REFERENCE
)
8082 /* Returns a reference to the scalar evaluated outside the loop
8084 gfc_conv_expr (se
, expr
);
8086 if (expr
->ts
.type
== BT_CHARACTER
8087 && expr
->expr_type
!= EXPR_FUNCTION
)
8088 gfc_conv_string_parameter (se
);
8090 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
8095 if (expr
->ts
.type
== BT_CHARACTER
)
8097 gfc_conv_expr (se
, expr
);
8098 gfc_conv_string_parameter (se
);
8102 if (expr
->expr_type
== EXPR_VARIABLE
)
8104 se
->want_pointer
= 1;
8105 gfc_conv_expr (se
, expr
);
8108 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8109 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8110 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8113 else if (add_clobber
)
8117 /* FIXME: This fails if var is passed by reference, see PR
8119 var
= expr
->symtree
->n
.sym
->backend_decl
;
8120 clobber
= build_clobber (TREE_TYPE (var
));
8121 gfc_add_modify (&se
->pre
, var
, clobber
);
8126 if (expr
->expr_type
== EXPR_FUNCTION
8127 && ((expr
->value
.function
.esym
8128 && expr
->value
.function
.esym
->result
->attr
.pointer
8129 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8130 || (!expr
->value
.function
.esym
&& !expr
->ref
8131 && expr
->symtree
->n
.sym
->attr
.pointer
8132 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8134 se
->want_pointer
= 1;
8135 gfc_conv_expr (se
, expr
);
8136 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8137 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8142 gfc_conv_expr (se
, expr
);
8144 /* Create a temporary var to hold the value. */
8145 if (TREE_CONSTANT (se
->expr
))
8147 tree tmp
= se
->expr
;
8148 STRIP_TYPE_NOPS (tmp
);
8149 var
= build_decl (input_location
,
8150 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8151 DECL_INITIAL (var
) = tmp
;
8152 TREE_STATIC (var
) = 1;
8157 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8158 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8161 if (!expr
->must_finalize
)
8162 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8164 /* Take the address of that value. */
8165 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8169 /* Get the _len component for an unlimited polymorphic expression. */
8172 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8175 gfc_ref
*ref
= expr
->ref
;
8177 gfc_init_se (&se
, NULL
);
8178 while (ref
&& ref
->next
)
8180 gfc_add_len_component (expr
);
8181 gfc_conv_expr (&se
, expr
);
8182 gfc_add_block_to_block (block
, &se
.pre
);
8183 gcc_assert (se
.post
.head
== NULL_TREE
);
8186 gfc_free_ref_list (ref
->next
);
8191 gfc_free_ref_list (expr
->ref
);
8198 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8199 statement-list outside of the scalarizer-loop. When code is generated, that
8200 depends on the scalarized expression, it is added to RSE.PRE.
8201 Returns le's _vptr tree and when set the len expressions in to_lenp and
8202 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8206 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8207 gfc_expr
* re
, gfc_se
*rse
,
8208 tree
* to_lenp
, tree
* from_lenp
)
8211 gfc_expr
* vptr_expr
;
8212 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8213 bool set_vptr
= false, temp_rhs
= false;
8214 stmtblock_t
*pre
= block
;
8216 /* Create a temporary for complicated expressions. */
8217 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8218 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8220 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8222 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8227 /* Get the _vptr for the left-hand side expression. */
8228 gfc_init_se (&se
, NULL
);
8229 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8230 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8232 /* Care about _len for unlimited polymorphic entities. */
8233 if (UNLIMITED_POLY (vptr_expr
)
8234 || (vptr_expr
->ts
.type
== BT_DERIVED
8235 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8236 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8237 gfc_add_vptr_component (vptr_expr
);
8241 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8242 se
.want_pointer
= 1;
8243 gfc_conv_expr (&se
, vptr_expr
);
8244 gfc_free_expr (vptr_expr
);
8245 gfc_add_block_to_block (block
, &se
.pre
);
8246 gcc_assert (se
.post
.head
== NULL_TREE
);
8248 STRIP_NOPS (lhs_vptr
);
8250 /* Set the _vptr only when the left-hand side of the assignment is a
8254 /* Get the vptr from the rhs expression only, when it is variable.
8255 Functions are expected to be assigned to a temporary beforehand. */
8256 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8257 ? gfc_find_and_cut_at_last_class_ref (re
)
8259 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8261 if (to_len
!= NULL_TREE
)
8263 /* Get the _len information from the rhs. */
8264 if (UNLIMITED_POLY (vptr_expr
)
8265 || (vptr_expr
->ts
.type
== BT_DERIVED
8266 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8267 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8269 gfc_add_vptr_component (vptr_expr
);
8273 if (re
->expr_type
== EXPR_VARIABLE
8274 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8275 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8276 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8277 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8278 re
->symtree
->n
.sym
->backend_decl
))))
8281 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8282 re
->symtree
->n
.sym
->backend_decl
));
8284 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8285 re
->symtree
->n
.sym
->backend_decl
));
8287 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8290 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8291 if (UNLIMITED_POLY (re
))
8292 from_len
= gfc_class_len_get (rse
->expr
);
8294 else if (re
->expr_type
!= EXPR_NULL
)
8295 /* Only when rhs is non-NULL use its declared type for vptr
8297 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8299 /* When the rhs is NULL use the vtab of lhs' declared type. */
8300 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8305 gfc_init_se (&se
, NULL
);
8306 se
.want_pointer
= 1;
8307 gfc_conv_expr (&se
, vptr_expr
);
8308 gfc_free_expr (vptr_expr
);
8309 gfc_add_block_to_block (block
, &se
.pre
);
8310 gcc_assert (se
.post
.head
== NULL_TREE
);
8312 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8315 if (to_len
!= NULL_TREE
)
8317 /* The _len component needs to be set. Figure how to get the
8318 value of the right-hand side. */
8319 if (from_len
== NULL_TREE
)
8321 if (rse
->string_length
!= NULL_TREE
)
8322 from_len
= rse
->string_length
;
8323 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8325 from_len
= gfc_get_expr_charlen (re
);
8326 gfc_init_se (&se
, NULL
);
8327 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8328 gfc_add_block_to_block (block
, &se
.pre
);
8329 gcc_assert (se
.post
.head
== NULL_TREE
);
8330 from_len
= gfc_evaluate_now (se
.expr
, block
);
8333 from_len
= build_zero_cst (gfc_charlen_type_node
);
8335 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8340 /* Return the _len trees only, when requested. */
8344 *from_lenp
= from_len
;
8349 /* Assign tokens for pointer components. */
8352 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8355 symbol_attribute lhs_attr
, rhs_attr
;
8356 tree tmp
, lhs_tok
, rhs_tok
;
8357 /* Flag to indicated component refs on the rhs. */
8360 lhs_attr
= gfc_caf_attr (expr1
);
8361 if (expr2
->expr_type
!= EXPR_NULL
)
8363 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8364 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8366 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8367 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8370 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8374 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8375 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8378 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8380 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8381 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8384 else if (lhs_attr
.codimension
)
8386 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8387 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8388 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8389 lhs_tok
, null_pointer_node
);
8390 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8394 /* Indentify class valued proc_pointer assignments. */
8397 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8402 while (ref
&& ref
->next
)
8405 return ref
&& ref
->type
== REF_COMPONENT
8406 && ref
->u
.c
.component
->attr
.proc_pointer
8407 && expr2
->expr_type
== EXPR_VARIABLE
8408 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8412 /* Do everything that is needed for a CLASS function expr2. */
8415 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8416 gfc_expr
*expr1
, gfc_expr
*expr2
)
8418 tree expr1_vptr
= NULL_TREE
;
8421 gfc_conv_function_expr (rse
, expr2
);
8422 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8424 if (expr1
->ts
.type
!= BT_CLASS
)
8425 rse
->expr
= gfc_class_data_get (rse
->expr
);
8428 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8431 gfc_add_block_to_block (block
, &rse
->pre
);
8432 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8433 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8435 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8436 fold_convert (TREE_TYPE (expr1_vptr
),
8437 gfc_class_vptr_get (tmp
)));
8438 rse
->expr
= gfc_class_data_get (tmp
);
8446 gfc_trans_pointer_assign (gfc_code
* code
)
8448 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8452 /* Generate code for a pointer assignment. */
8455 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8462 tree expr1_vptr
= NULL_TREE
;
8463 bool scalar
, non_proc_pointer_assign
;
8466 gfc_start_block (&block
);
8468 gfc_init_se (&lse
, NULL
);
8470 /* Usually testing whether this is not a proc pointer assignment. */
8471 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8473 /* Check whether the expression is a scalar or not; we cannot use
8474 expr1->rank as it can be nonzero for proc pointers. */
8475 ss
= gfc_walk_expr (expr1
);
8476 scalar
= ss
== gfc_ss_terminator
;
8478 gfc_free_ss_chain (ss
);
8480 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8481 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8483 gfc_add_data_component (expr2
);
8484 /* The following is required as gfc_add_data_component doesn't
8485 update ts.type if there is a tailing REF_ARRAY. */
8486 expr2
->ts
.type
= BT_DERIVED
;
8491 /* Scalar pointers. */
8492 lse
.want_pointer
= 1;
8493 gfc_conv_expr (&lse
, expr1
);
8494 gfc_init_se (&rse
, NULL
);
8495 rse
.want_pointer
= 1;
8496 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8497 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8499 gfc_conv_expr (&rse
, expr2
);
8501 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8503 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8505 lse
.expr
= gfc_class_data_get (lse
.expr
);
8508 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8509 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8510 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8513 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8514 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8515 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8518 gfc_add_block_to_block (&block
, &lse
.pre
);
8519 gfc_add_block_to_block (&block
, &rse
.pre
);
8521 /* Check character lengths if character expression. The test is only
8522 really added if -fbounds-check is enabled. Exclude deferred
8523 character length lefthand sides. */
8524 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8525 && !expr1
->ts
.deferred
8526 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8527 && !gfc_is_proc_ptr_comp (expr1
))
8529 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8530 gcc_assert (lse
.string_length
&& rse
.string_length
);
8531 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8532 lse
.string_length
, rse
.string_length
,
8536 /* The assignment to an deferred character length sets the string
8537 length to that of the rhs. */
8538 if (expr1
->ts
.deferred
)
8540 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8541 gfc_add_modify (&block
, lse
.string_length
,
8542 fold_convert (TREE_TYPE (lse
.string_length
),
8543 rse
.string_length
));
8544 else if (lse
.string_length
!= NULL
)
8545 gfc_add_modify (&block
, lse
.string_length
,
8546 build_zero_cst (TREE_TYPE (lse
.string_length
)));
8549 gfc_add_modify (&block
, lse
.expr
,
8550 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8552 /* Also set the tokens for pointer components in derived typed
8554 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8555 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8557 gfc_add_block_to_block (&block
, &rse
.post
);
8558 gfc_add_block_to_block (&block
, &lse
.post
);
8565 tree strlen_rhs
= NULL_TREE
;
8567 /* Array pointer. Find the last reference on the LHS and if it is an
8568 array section ref, we're dealing with bounds remapping. In this case,
8569 set it to AR_FULL so that gfc_conv_expr_descriptor does
8570 not see it and process the bounds remapping afterwards explicitly. */
8571 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8572 if (!remap
->next
&& remap
->type
== REF_ARRAY
8573 && remap
->u
.ar
.type
== AR_SECTION
)
8575 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8577 gfc_init_se (&lse
, NULL
);
8579 lse
.descriptor_only
= 1;
8580 gfc_conv_expr_descriptor (&lse
, expr1
);
8581 strlen_lhs
= lse
.string_length
;
8584 if (expr2
->expr_type
== EXPR_NULL
)
8586 /* Just set the data pointer to null. */
8587 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8589 else if (rank_remap
)
8591 /* If we are rank-remapping, just get the RHS's descriptor and
8592 process this later on. */
8593 gfc_init_se (&rse
, NULL
);
8594 rse
.direct_byref
= 1;
8595 rse
.byref_noassign
= 1;
8597 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8598 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8600 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8602 tree bound
[GFC_MAX_DIMENSIONS
];
8605 for (i
= 0; i
< expr2
->rank
; i
++)
8606 bound
[i
] = NULL_TREE
;
8607 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8608 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8610 GFC_ARRAY_POINTER_CONT
, false);
8611 tmp
= gfc_create_var (tmp
, "ptrtemp");
8612 rse
.descriptor_only
= 0;
8614 rse
.direct_byref
= 1;
8615 gfc_conv_expr_descriptor (&rse
, expr2
);
8616 strlen_rhs
= rse
.string_length
;
8621 gfc_conv_expr_descriptor (&rse
, expr2
);
8622 strlen_rhs
= rse
.string_length
;
8623 if (expr1
->ts
.type
== BT_CLASS
)
8624 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8629 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8631 /* Assign directly to the LHS's descriptor. */
8632 lse
.descriptor_only
= 0;
8633 lse
.direct_byref
= 1;
8634 gfc_conv_expr_descriptor (&lse
, expr2
);
8635 strlen_rhs
= lse
.string_length
;
8637 if (expr1
->ts
.type
== BT_CLASS
)
8639 rse
.expr
= NULL_TREE
;
8640 rse
.string_length
= NULL_TREE
;
8641 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8647 /* If the target is not a whole array, use the target array
8648 reference for remap. */
8649 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8650 if (remap
->type
== REF_ARRAY
8651 && remap
->u
.ar
.type
== AR_FULL
8656 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8658 gfc_init_se (&rse
, NULL
);
8659 rse
.want_pointer
= 1;
8660 gfc_conv_function_expr (&rse
, expr2
);
8661 if (expr1
->ts
.type
!= BT_CLASS
)
8663 rse
.expr
= gfc_class_data_get (rse
.expr
);
8664 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8665 /* Set the lhs span. */
8666 tmp
= TREE_TYPE (rse
.expr
);
8667 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8668 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8669 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8673 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8676 gfc_add_block_to_block (&block
, &rse
.pre
);
8677 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8678 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8680 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8681 fold_convert (TREE_TYPE (expr1_vptr
),
8682 gfc_class_vptr_get (tmp
)));
8683 rse
.expr
= gfc_class_data_get (tmp
);
8684 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8689 /* Assign to a temporary descriptor and then copy that
8690 temporary to the pointer. */
8691 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8692 lse
.descriptor_only
= 0;
8694 lse
.direct_byref
= 1;
8695 gfc_conv_expr_descriptor (&lse
, expr2
);
8696 strlen_rhs
= lse
.string_length
;
8697 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8700 gfc_add_block_to_block (&block
, &lse
.pre
);
8702 gfc_add_block_to_block (&block
, &rse
.pre
);
8704 /* If we do bounds remapping, update LHS descriptor accordingly. */
8708 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8712 /* Do rank remapping. We already have the RHS's descriptor
8713 converted in rse and now have to build the correct LHS
8714 descriptor for it. */
8716 tree dtype
, data
, span
;
8718 tree lbound
, ubound
;
8721 dtype
= gfc_conv_descriptor_dtype (desc
);
8722 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8723 gfc_add_modify (&block
, dtype
, tmp
);
8725 /* Copy data pointer. */
8726 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8727 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8729 /* Copy the span. */
8730 if (TREE_CODE (rse
.expr
) == VAR_DECL
8731 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8732 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8735 tmp
= TREE_TYPE (rse
.expr
);
8736 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8737 span
= fold_convert (gfc_array_index_type
, tmp
);
8739 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8741 /* Copy offset but adjust it such that it would correspond
8742 to a lbound of zero. */
8743 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8744 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8746 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8748 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8750 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8751 gfc_array_index_type
, stride
, lbound
);
8752 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8753 gfc_array_index_type
, offs
, tmp
);
8755 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8757 /* Set the bounds as declared for the LHS and calculate strides as
8758 well as another offset update accordingly. */
8759 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8761 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8766 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8768 /* Convert declared bounds. */
8769 gfc_init_se (&lower_se
, NULL
);
8770 gfc_init_se (&upper_se
, NULL
);
8771 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8772 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8774 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8775 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8777 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8778 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8780 lbound
= gfc_evaluate_now (lbound
, &block
);
8781 ubound
= gfc_evaluate_now (ubound
, &block
);
8783 gfc_add_block_to_block (&block
, &lower_se
.post
);
8784 gfc_add_block_to_block (&block
, &upper_se
.post
);
8786 /* Set bounds in descriptor. */
8787 gfc_conv_descriptor_lbound_set (&block
, desc
,
8788 gfc_rank_cst
[dim
], lbound
);
8789 gfc_conv_descriptor_ubound_set (&block
, desc
,
8790 gfc_rank_cst
[dim
], ubound
);
8793 stride
= gfc_evaluate_now (stride
, &block
);
8794 gfc_conv_descriptor_stride_set (&block
, desc
,
8795 gfc_rank_cst
[dim
], stride
);
8797 /* Update offset. */
8798 offs
= gfc_conv_descriptor_offset_get (desc
);
8799 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8800 gfc_array_index_type
, lbound
, stride
);
8801 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8802 gfc_array_index_type
, offs
, tmp
);
8803 offs
= gfc_evaluate_now (offs
, &block
);
8804 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8806 /* Update stride. */
8807 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8808 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8809 gfc_array_index_type
, stride
, tmp
);
8814 /* Bounds remapping. Just shift the lower bounds. */
8816 gcc_assert (expr1
->rank
== expr2
->rank
);
8818 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8822 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8823 gfc_init_se (&lbound_se
, NULL
);
8824 if (remap
->u
.ar
.start
[dim
])
8826 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8827 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8830 /* This remap arises from a target that is not a whole
8831 array. The start expressions will be NULL but we need
8832 the lbounds to be one. */
8833 lbound_se
.expr
= gfc_index_one_node
;
8834 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8835 dim
, lbound_se
.expr
);
8836 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8841 /* Check string lengths if applicable. The check is only really added
8842 to the output code if -fbounds-check is enabled. */
8843 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8845 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8846 gcc_assert (strlen_lhs
&& strlen_rhs
);
8847 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8848 strlen_lhs
, strlen_rhs
, &block
);
8851 /* If rank remapping was done, check with -fcheck=bounds that
8852 the target is at least as large as the pointer. */
8853 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8859 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8860 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8862 lsize
= gfc_evaluate_now (lsize
, &block
);
8863 rsize
= gfc_evaluate_now (rsize
, &block
);
8864 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
8867 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8868 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8872 gfc_add_block_to_block (&block
, &lse
.post
);
8874 gfc_add_block_to_block (&block
, &rse
.post
);
8877 return gfc_finish_block (&block
);
8881 /* Makes sure se is suitable for passing as a function string parameter. */
8882 /* TODO: Need to check all callers of this function. It may be abused. */
8885 gfc_conv_string_parameter (gfc_se
* se
)
8889 if (TREE_CODE (se
->expr
) == STRING_CST
)
8891 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8892 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8896 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8898 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8900 type
= TREE_TYPE (se
->expr
);
8901 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8905 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8907 type
= build_pointer_type (type
);
8908 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8912 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8916 /* Generate code for assignment of scalar variables. Includes character
8917 strings and derived types with allocatable components.
8918 If you know that the LHS has no allocations, set dealloc to false.
8920 DEEP_COPY has no effect if the typespec TS is not a derived type with
8921 allocatable components. Otherwise, if it is set, an explicit copy of each
8922 allocatable component is made. This is necessary as a simple copy of the
8923 whole object would copy array descriptors as is, so that the lhs's
8924 allocatable components would point to the rhs's after the assignment.
8925 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8926 necessary if the rhs is a non-pointer function, as the allocatable components
8927 are not accessible by other means than the function's result after the
8928 function has returned. It is even more subtle when temporaries are involved,
8929 as the two following examples show:
8930 1. When we evaluate an array constructor, a temporary is created. Thus
8931 there is theoretically no alias possible. However, no deep copy is
8932 made for this temporary, so that if the constructor is made of one or
8933 more variable with allocatable components, those components still point
8934 to the variable's: DEEP_COPY should be set for the assignment from the
8935 temporary to the lhs in that case.
8936 2. When assigning a scalar to an array, we evaluate the scalar value out
8937 of the loop, store it into a temporary variable, and assign from that.
8938 In that case, deep copying when assigning to the temporary would be a
8939 waste of resources; however deep copies should happen when assigning from
8940 the temporary to each array element: again DEEP_COPY should be set for
8941 the assignment from the temporary to the lhs. */
8944 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8945 bool deep_copy
, bool dealloc
, bool in_coarray
)
8951 gfc_init_block (&block
);
8953 if (ts
.type
== BT_CHARACTER
)
8958 if (lse
->string_length
!= NULL_TREE
)
8960 gfc_conv_string_parameter (lse
);
8961 gfc_add_block_to_block (&block
, &lse
->pre
);
8962 llen
= lse
->string_length
;
8965 if (rse
->string_length
!= NULL_TREE
)
8967 gfc_conv_string_parameter (rse
);
8968 gfc_add_block_to_block (&block
, &rse
->pre
);
8969 rlen
= rse
->string_length
;
8972 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8973 rse
->expr
, ts
.kind
);
8975 else if (gfc_bt_struct (ts
.type
)
8976 && (ts
.u
.derived
->attr
.alloc_comp
8977 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
8979 tree tmp_var
= NULL_TREE
;
8982 /* Are the rhs and the lhs the same? */
8985 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8986 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8987 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8988 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8991 /* Deallocate the lhs allocated components as long as it is not
8992 the same as the rhs. This must be done following the assignment
8993 to prevent deallocating data that could be used in the rhs
8997 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8998 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
9000 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9002 gfc_add_expr_to_block (&lse
->post
, tmp
);
9005 gfc_add_block_to_block (&block
, &rse
->pre
);
9006 gfc_add_block_to_block (&block
, &lse
->pre
);
9008 gfc_add_modify (&block
, lse
->expr
,
9009 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9011 /* Restore pointer address of coarray components. */
9012 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
9014 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
9015 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9017 gfc_add_expr_to_block (&block
, tmp
);
9020 /* Do a deep copy if the rhs is a variable, if it is not the
9024 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9025 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
9026 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
9028 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
9030 gfc_add_expr_to_block (&block
, tmp
);
9033 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
9035 gfc_add_block_to_block (&block
, &lse
->pre
);
9036 gfc_add_block_to_block (&block
, &rse
->pre
);
9037 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
9038 TREE_TYPE (lse
->expr
), rse
->expr
);
9039 gfc_add_modify (&block
, lse
->expr
, tmp
);
9043 gfc_add_block_to_block (&block
, &lse
->pre
);
9044 gfc_add_block_to_block (&block
, &rse
->pre
);
9046 gfc_add_modify (&block
, lse
->expr
,
9047 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
9050 gfc_add_block_to_block (&block
, &lse
->post
);
9051 gfc_add_block_to_block (&block
, &rse
->post
);
9053 return gfc_finish_block (&block
);
9057 /* There are quite a lot of restrictions on the optimisation in using an
9058 array function assign without a temporary. */
9061 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
9064 bool seen_array_ref
;
9066 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
9068 /* Play it safe with class functions assigned to a derived type. */
9069 if (gfc_is_class_array_function (expr2
)
9070 && expr1
->ts
.type
== BT_DERIVED
)
9073 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9074 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
9077 /* Elemental functions are scalarized so that they don't need a
9078 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9079 they would need special treatment in gfc_trans_arrayfunc_assign. */
9080 if (expr2
->value
.function
.esym
!= NULL
9081 && expr2
->value
.function
.esym
->attr
.elemental
)
9084 /* Need a temporary if rhs is not FULL or a contiguous section. */
9085 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
9088 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9089 if (gfc_ref_needs_temporary_p (expr1
->ref
))
9092 /* Functions returning pointers or allocatables need temporaries. */
9093 c
= expr2
->value
.function
.esym
9094 ? (expr2
->value
.function
.esym
->attr
.pointer
9095 || expr2
->value
.function
.esym
->attr
.allocatable
)
9096 : (expr2
->symtree
->n
.sym
->attr
.pointer
9097 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
9101 /* Character array functions need temporaries unless the
9102 character lengths are the same. */
9103 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
9105 if (expr1
->ts
.u
.cl
->length
== NULL
9106 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9109 if (expr2
->ts
.u
.cl
->length
== NULL
9110 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9113 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9114 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9118 /* Check that no LHS component references appear during an array
9119 reference. This is needed because we do not have the means to
9120 span any arbitrary stride with an array descriptor. This check
9121 is not needed for the rhs because the function result has to be
9123 seen_array_ref
= false;
9124 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9126 if (ref
->type
== REF_ARRAY
)
9127 seen_array_ref
= true;
9128 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9132 /* Check for a dependency. */
9133 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9134 expr2
->value
.function
.esym
,
9135 expr2
->value
.function
.actual
,
9139 /* If we have reached here with an intrinsic function, we do not
9140 need a temporary except in the particular case that reallocation
9141 on assignment is active and the lhs is allocatable and a target. */
9142 if (expr2
->value
.function
.isym
)
9143 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9145 /* If the LHS is a dummy, we need a temporary if it is not
9147 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9150 /* If the lhs has been host_associated, is in common, a pointer or is
9151 a target and the function is not using a RESULT variable, aliasing
9152 can occur and a temporary is needed. */
9153 if ((sym
->attr
.host_assoc
9154 || sym
->attr
.in_common
9155 || sym
->attr
.pointer
9156 || sym
->attr
.cray_pointee
9157 || sym
->attr
.target
)
9158 && expr2
->symtree
!= NULL
9159 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9162 /* A PURE function can unconditionally be called without a temporary. */
9163 if (expr2
->value
.function
.esym
!= NULL
9164 && expr2
->value
.function
.esym
->attr
.pure
)
9167 /* Implicit_pure functions are those which could legally be declared
9169 if (expr2
->value
.function
.esym
!= NULL
9170 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9173 if (!sym
->attr
.use_assoc
9174 && !sym
->attr
.in_common
9175 && !sym
->attr
.pointer
9176 && !sym
->attr
.target
9177 && !sym
->attr
.cray_pointee
9178 && expr2
->value
.function
.esym
)
9180 /* A temporary is not needed if the function is not contained and
9181 the variable is local or host associated and not a pointer or
9183 if (!expr2
->value
.function
.esym
->attr
.contained
)
9186 /* A temporary is not needed if the lhs has never been host
9187 associated and the procedure is contained. */
9188 else if (!sym
->attr
.host_assoc
)
9191 /* A temporary is not needed if the variable is local and not
9192 a pointer, a target or a result. */
9194 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9198 /* Default to temporary use. */
9203 /* Provide the loop info so that the lhs descriptor can be built for
9204 reallocatable assignments from extrinsic function calls. */
9207 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9210 /* Signal that the function call should not be made by
9211 gfc_conv_loop_setup. */
9212 se
->ss
->is_alloc_lhs
= 1;
9213 gfc_init_loopinfo (loop
);
9214 gfc_add_ss_to_loop (loop
, *ss
);
9215 gfc_add_ss_to_loop (loop
, se
->ss
);
9216 gfc_conv_ss_startstride (loop
);
9217 gfc_conv_loop_setup (loop
, where
);
9218 gfc_copy_loopinfo_to_se (se
, loop
);
9219 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9220 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9221 se
->ss
->is_alloc_lhs
= 0;
9225 /* For assignment to a reallocatable lhs from intrinsic functions,
9226 replace the se.expr (ie. the result) with a temporary descriptor.
9227 Null the data field so that the library allocates space for the
9228 result. Free the data of the original descriptor after the function,
9229 in case it appears in an argument expression and transfer the
9230 result to the original descriptor. */
9233 fcncall_realloc_result (gfc_se
*se
, int rank
)
9242 /* Use the allocation done by the library. Substitute the lhs
9243 descriptor with a copy, whose data field is nulled.*/
9244 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9245 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9246 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9248 /* Unallocated, the descriptor does not have a dtype. */
9249 tmp
= gfc_conv_descriptor_dtype (desc
);
9250 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9252 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9253 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9254 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9256 /* Free the lhs after the function call and copy the result data to
9257 the lhs descriptor. */
9258 tmp
= gfc_conv_descriptor_data_get (desc
);
9259 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9260 logical_type_node
, tmp
,
9261 build_int_cst (TREE_TYPE (tmp
), 0));
9262 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9263 tmp
= gfc_call_free (tmp
);
9264 gfc_add_expr_to_block (&se
->post
, tmp
);
9266 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9267 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9269 /* Check that the shapes are the same between lhs and expression. */
9270 for (n
= 0 ; n
< rank
; n
++)
9273 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9274 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9275 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9276 gfc_array_index_type
, tmp
, tmp1
);
9277 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9278 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9279 gfc_array_index_type
, tmp
, tmp1
);
9280 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9281 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9282 gfc_array_index_type
, tmp
, tmp1
);
9283 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9284 logical_type_node
, tmp
,
9285 gfc_index_zero_node
);
9286 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9287 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9288 logical_type_node
, tmp
,
9292 /* 'zero_cond' being true is equal to lhs not being allocated or the
9293 shapes being different. */
9294 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9296 /* Now reset the bounds returned from the function call to bounds based
9297 on the lhs lbounds, except where the lhs is not allocated or the shapes
9298 of 'variable and 'expr' are different. Set the offset accordingly. */
9299 offset
= gfc_index_zero_node
;
9300 for (n
= 0 ; n
< rank
; n
++)
9304 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9305 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9306 gfc_array_index_type
, zero_cond
,
9307 gfc_index_one_node
, lbound
);
9308 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9310 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9311 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9312 gfc_array_index_type
, tmp
, lbound
);
9313 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9314 gfc_rank_cst
[n
], lbound
);
9315 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9316 gfc_rank_cst
[n
], tmp
);
9318 /* Set stride and accumulate the offset. */
9319 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9320 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9321 gfc_rank_cst
[n
], tmp
);
9322 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9323 gfc_array_index_type
, lbound
, tmp
);
9324 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9325 gfc_array_index_type
, offset
, tmp
);
9326 offset
= gfc_evaluate_now (offset
, &se
->post
);
9329 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9334 /* Try to translate array(:) = func (...), where func is a transformational
9335 array function, without using a temporary. Returns NULL if this isn't the
9339 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9343 gfc_component
*comp
= NULL
;
9346 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9349 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9351 comp
= gfc_get_proc_ptr_comp (expr2
);
9353 if (!(expr2
->value
.function
.isym
9354 || (comp
&& comp
->attr
.dimension
)
9355 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9356 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
9359 gfc_init_se (&se
, NULL
);
9360 gfc_start_block (&se
.pre
);
9361 se
.want_pointer
= 1;
9363 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9365 if (expr1
->ts
.type
== BT_DERIVED
9366 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9369 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9371 gfc_add_expr_to_block (&se
.pre
, tmp
);
9374 se
.direct_byref
= 1;
9375 se
.ss
= gfc_walk_expr (expr2
);
9376 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9378 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9379 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9380 Clearly, this cannot be done for an allocatable function result, since
9381 the shape of the result is unknown and, in any case, the function must
9382 correctly take care of the reallocation internally. For intrinsic
9383 calls, the array data is freed and the library takes care of allocation.
9384 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9386 if (flag_realloc_lhs
9387 && gfc_is_reallocatable_lhs (expr1
)
9388 && !gfc_expr_attr (expr1
).codimension
9389 && !gfc_is_coindexed (expr1
)
9390 && !(expr2
->value
.function
.esym
9391 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9393 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9395 if (!expr2
->value
.function
.isym
)
9397 ss
= gfc_walk_expr (expr1
);
9398 gcc_assert (ss
!= gfc_ss_terminator
);
9400 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9401 ss
->is_alloc_lhs
= 1;
9404 fcncall_realloc_result (&se
, expr1
->rank
);
9407 gfc_conv_function_expr (&se
, expr2
);
9408 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9411 gfc_cleanup_loop (&loop
);
9413 gfc_free_ss_chain (se
.ss
);
9415 return gfc_finish_block (&se
.pre
);
9419 /* Try to efficiently translate array(:) = 0. Return NULL if this
9423 gfc_trans_zero_assign (gfc_expr
* expr
)
9425 tree dest
, len
, type
;
9429 sym
= expr
->symtree
->n
.sym
;
9430 dest
= gfc_get_symbol_decl (sym
);
9432 type
= TREE_TYPE (dest
);
9433 if (POINTER_TYPE_P (type
))
9434 type
= TREE_TYPE (type
);
9435 if (!GFC_ARRAY_TYPE_P (type
))
9438 /* Determine the length of the array. */
9439 len
= GFC_TYPE_ARRAY_SIZE (type
);
9440 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9443 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9444 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9445 fold_convert (gfc_array_index_type
, tmp
));
9447 /* If we are zeroing a local array avoid taking its address by emitting
9449 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9450 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9451 dest
, build_constructor (TREE_TYPE (dest
),
9454 /* Convert arguments to the correct types. */
9455 dest
= fold_convert (pvoid_type_node
, dest
);
9456 len
= fold_convert (size_type_node
, len
);
9458 /* Construct call to __builtin_memset. */
9459 tmp
= build_call_expr_loc (input_location
,
9460 builtin_decl_explicit (BUILT_IN_MEMSET
),
9461 3, dest
, integer_zero_node
, len
);
9462 return fold_convert (void_type_node
, tmp
);
9466 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9467 that constructs the call to __builtin_memcpy. */
9470 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9474 /* Convert arguments to the correct types. */
9475 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9476 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9478 dst
= fold_convert (pvoid_type_node
, dst
);
9480 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9481 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9483 src
= fold_convert (pvoid_type_node
, src
);
9485 len
= fold_convert (size_type_node
, len
);
9487 /* Construct call to __builtin_memcpy. */
9488 tmp
= build_call_expr_loc (input_location
,
9489 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9491 return fold_convert (void_type_node
, tmp
);
9495 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9496 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9497 source/rhs, both are gfc_full_array_ref_p which have been checked for
9501 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9503 tree dst
, dlen
, dtype
;
9504 tree src
, slen
, stype
;
9507 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9508 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9510 dtype
= TREE_TYPE (dst
);
9511 if (POINTER_TYPE_P (dtype
))
9512 dtype
= TREE_TYPE (dtype
);
9513 stype
= TREE_TYPE (src
);
9514 if (POINTER_TYPE_P (stype
))
9515 stype
= TREE_TYPE (stype
);
9517 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9520 /* Determine the lengths of the arrays. */
9521 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9522 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9524 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9525 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9526 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9528 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9529 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9531 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9532 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9533 slen
, fold_convert (gfc_array_index_type
, tmp
));
9535 /* Sanity check that they are the same. This should always be
9536 the case, as we should already have checked for conformance. */
9537 if (!tree_int_cst_equal (slen
, dlen
))
9540 return gfc_build_memcpy_call (dst
, src
, dlen
);
9544 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9545 this can't be done. EXPR1 is the destination/lhs for which
9546 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9549 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9551 unsigned HOST_WIDE_INT nelem
;
9557 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9561 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9562 dtype
= TREE_TYPE (dst
);
9563 if (POINTER_TYPE_P (dtype
))
9564 dtype
= TREE_TYPE (dtype
);
9565 if (!GFC_ARRAY_TYPE_P (dtype
))
9568 /* Determine the lengths of the array. */
9569 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9570 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9573 /* Confirm that the constructor is the same size. */
9574 if (compare_tree_int (len
, nelem
) != 0)
9577 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9578 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9579 fold_convert (gfc_array_index_type
, tmp
));
9581 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9582 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9584 stype
= TREE_TYPE (src
);
9585 if (POINTER_TYPE_P (stype
))
9586 stype
= TREE_TYPE (stype
);
9588 return gfc_build_memcpy_call (dst
, src
, len
);
9592 /* Tells whether the expression is to be treated as a variable reference. */
9595 gfc_expr_is_variable (gfc_expr
*expr
)
9598 gfc_component
*comp
;
9599 gfc_symbol
*func_ifc
;
9601 if (expr
->expr_type
== EXPR_VARIABLE
)
9604 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9607 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9608 return gfc_expr_is_variable (arg
);
9611 /* A data-pointer-returning function should be considered as a variable
9613 if (expr
->expr_type
== EXPR_FUNCTION
9614 && expr
->ref
== NULL
)
9616 if (expr
->value
.function
.isym
!= NULL
)
9619 if (expr
->value
.function
.esym
!= NULL
)
9621 func_ifc
= expr
->value
.function
.esym
;
9626 gcc_assert (expr
->symtree
);
9627 func_ifc
= expr
->symtree
->n
.sym
;
9634 comp
= gfc_get_proc_ptr_comp (expr
);
9635 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9638 func_ifc
= comp
->ts
.interface
;
9642 if (expr
->expr_type
== EXPR_COMPCALL
)
9644 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9645 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9652 gcc_assert (func_ifc
->attr
.function
9653 && func_ifc
->result
!= NULL
);
9654 return func_ifc
->result
->attr
.pointer
;
9658 /* Is the lhs OK for automatic reallocation? */
9661 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9665 /* An allocatable variable with no reference. */
9666 if (expr
->symtree
->n
.sym
->attr
.allocatable
9670 /* All that can be left are allocatable components. However, we do
9671 not check for allocatable components here because the expression
9672 could be an allocatable component of a pointer component. */
9673 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9674 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9677 /* Find an allocatable component ref last. */
9678 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9679 if (ref
->type
== REF_COMPONENT
9681 && ref
->u
.c
.component
->attr
.allocatable
)
9688 /* Allocate or reallocate scalar lhs, as necessary. */
9691 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9706 if (!expr1
|| expr1
->rank
)
9709 if (!expr2
|| expr2
->rank
)
9712 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9713 if (ref
->type
== REF_SUBSTRING
)
9716 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9718 /* Since this is a scalar lhs, we can afford to do this. That is,
9719 there is no risk of side effects being repeated. */
9720 gfc_init_se (&lse
, NULL
);
9721 lse
.want_pointer
= 1;
9722 gfc_conv_expr (&lse
, expr1
);
9724 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9725 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9727 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9728 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9729 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9731 tmp
= build3_v (COND_EXPR
, cond
,
9732 build1_v (GOTO_EXPR
, jump_label1
),
9733 build_empty_stmt (input_location
));
9734 gfc_add_expr_to_block (block
, tmp
);
9736 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9738 /* Use the rhs string length and the lhs element size. */
9739 size
= string_length
;
9740 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9741 tmp
= TYPE_SIZE_UNIT (tmp
);
9742 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9743 TREE_TYPE (tmp
), tmp
,
9744 fold_convert (TREE_TYPE (tmp
), size
));
9748 /* Otherwise use the length in bytes of the rhs. */
9749 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9750 size_in_bytes
= size
;
9753 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9754 size_in_bytes
, size_one_node
);
9756 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9758 tree caf_decl
, token
;
9760 symbol_attribute attr
;
9762 gfc_clear_attr (&attr
);
9763 gfc_init_se (&caf_se
, NULL
);
9765 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9766 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9768 gfc_add_block_to_block (block
, &caf_se
.pre
);
9769 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9770 gfc_build_addr_expr (NULL_TREE
, token
),
9771 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9774 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9776 tmp
= build_call_expr_loc (input_location
,
9777 builtin_decl_explicit (BUILT_IN_CALLOC
),
9778 2, build_one_cst (size_type_node
),
9780 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9781 gfc_add_modify (block
, lse
.expr
, tmp
);
9785 tmp
= build_call_expr_loc (input_location
,
9786 builtin_decl_explicit (BUILT_IN_MALLOC
),
9788 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9789 gfc_add_modify (block
, lse
.expr
, tmp
);
9792 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9794 /* Deferred characters need checking for lhs and rhs string
9795 length. Other deferred parameter variables will have to
9797 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9798 gfc_add_expr_to_block (block
, tmp
);
9800 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9801 gfc_add_expr_to_block (block
, tmp
);
9803 /* For a deferred length character, reallocate if lengths of lhs and
9804 rhs are different. */
9805 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9807 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9809 fold_convert (TREE_TYPE (lse
.string_length
),
9811 /* Jump past the realloc if the lengths are the same. */
9812 tmp
= build3_v (COND_EXPR
, cond
,
9813 build1_v (GOTO_EXPR
, jump_label2
),
9814 build_empty_stmt (input_location
));
9815 gfc_add_expr_to_block (block
, tmp
);
9816 tmp
= build_call_expr_loc (input_location
,
9817 builtin_decl_explicit (BUILT_IN_REALLOC
),
9818 2, fold_convert (pvoid_type_node
, lse
.expr
),
9820 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9821 gfc_add_modify (block
, lse
.expr
, tmp
);
9822 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9823 gfc_add_expr_to_block (block
, tmp
);
9825 /* Update the lhs character length. */
9826 size
= string_length
;
9827 gfc_add_modify (block
, lse
.string_length
,
9828 fold_convert (TREE_TYPE (lse
.string_length
), size
));
9832 /* Check for assignments of the type
9836 to make sure we do not check for reallocation unneccessarily. */
9840 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9842 gfc_actual_arglist
*a
;
9845 switch (expr2
->expr_type
)
9848 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9851 if (expr2
->value
.function
.esym
9852 && expr2
->value
.function
.esym
->attr
.elemental
)
9854 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9857 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9862 else if (expr2
->value
.function
.isym
9863 && expr2
->value
.function
.isym
->elemental
)
9865 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9868 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9877 switch (expr2
->value
.op
.op
)
9880 case INTRINSIC_UPLUS
:
9881 case INTRINSIC_UMINUS
:
9882 case INTRINSIC_PARENTHESES
:
9883 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9885 case INTRINSIC_PLUS
:
9886 case INTRINSIC_MINUS
:
9887 case INTRINSIC_TIMES
:
9888 case INTRINSIC_DIVIDE
:
9889 case INTRINSIC_POWER
:
9893 case INTRINSIC_NEQV
:
9900 case INTRINSIC_EQ_OS
:
9901 case INTRINSIC_NE_OS
:
9902 case INTRINSIC_GT_OS
:
9903 case INTRINSIC_GE_OS
:
9904 case INTRINSIC_LT_OS
:
9905 case INTRINSIC_LE_OS
:
9907 e1
= expr2
->value
.op
.op1
;
9908 e2
= expr2
->value
.op
.op2
;
9910 if (e1
->rank
== 0 && e2
->rank
> 0)
9911 return is_runtime_conformable (expr1
, e2
);
9912 else if (e1
->rank
> 0 && e2
->rank
== 0)
9913 return is_runtime_conformable (expr1
, e1
);
9914 else if (e1
->rank
> 0 && e2
->rank
> 0)
9915 return is_runtime_conformable (expr1
, e1
)
9916 && is_runtime_conformable (expr1
, e2
);
9934 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9935 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
9938 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
9939 vec
<tree
, va_gc
> *args
= NULL
;
9941 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9944 /* Generate allocation of the lhs. */
9950 tmp
= gfc_vptr_size_get (vptr
);
9951 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9952 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9953 gfc_init_block (&alloc
);
9954 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
9955 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9956 logical_type_node
, class_han
,
9957 build_int_cst (prvoid_type_node
, 0));
9958 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
9960 PRED_FORTRAN_FAIL_ALLOC
),
9961 gfc_finish_block (&alloc
),
9962 build_empty_stmt (input_location
));
9963 gfc_add_expr_to_block (&lse
->pre
, tmp
);
9966 fcn
= gfc_vptr_copy_get (vptr
);
9968 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9969 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9972 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9973 || INDIRECT_REF_P (tmp
)
9974 || (rhs
->ts
.type
== BT_DERIVED
9975 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9976 && !rhs
->ts
.u
.derived
->attr
.pointer
9977 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9978 || (UNLIMITED_POLY (rhs
)
9979 && !CLASS_DATA (rhs
)->attr
.pointer
9980 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9981 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9983 vec_safe_push (args
, tmp
);
9984 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9985 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9986 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9987 || INDIRECT_REF_P (tmp
)
9988 || (lhs
->ts
.type
== BT_DERIVED
9989 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9990 && !lhs
->ts
.u
.derived
->attr
.pointer
9991 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9992 || (UNLIMITED_POLY (lhs
)
9993 && !CLASS_DATA (lhs
)->attr
.pointer
9994 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9995 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9997 vec_safe_push (args
, tmp
);
9999 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10001 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
10004 vec_safe_push (args
, from_len
);
10005 vec_safe_push (args
, to_len
);
10006 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
10008 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
10009 logical_type_node
, from_len
,
10010 build_zero_cst (TREE_TYPE (from_len
)));
10011 return fold_build3_loc (input_location
, COND_EXPR
,
10012 void_type_node
, tmp
,
10020 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
10021 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
10022 stmtblock_t tblock
;
10023 gfc_init_block (&tblock
);
10024 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
10025 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10026 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
10027 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
10028 /* When coming from a ptr_copy lhs and rhs are swapped. */
10029 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
10030 fold_convert (TREE_TYPE (rhst
), tmp
));
10031 return gfc_finish_block (&tblock
);
10035 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10036 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10037 init_flag indicates initialization expressions and dealloc that no
10038 deallocate prior assignment is needed (if in doubt, set true).
10039 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10040 routine instead of a pointer assignment. Alias resolution is only done,
10041 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10042 where it is known, that newly allocated memory on the lhs can never be
10043 an alias of the rhs. */
10046 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10047 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10052 gfc_ss
*lss_section
;
10059 bool scalar_to_array
;
10060 tree string_length
;
10062 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
10063 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
10064 bool is_poly_assign
;
10066 /* Assignment of the form lhs = rhs. */
10067 gfc_start_block (&block
);
10069 gfc_init_se (&lse
, NULL
);
10070 gfc_init_se (&rse
, NULL
);
10072 /* Walk the lhs. */
10073 lss
= gfc_walk_expr (expr1
);
10074 if (gfc_is_reallocatable_lhs (expr1
))
10076 lss
->no_bounds_check
= 1;
10077 if (!(expr2
->expr_type
== EXPR_FUNCTION
10078 && expr2
->value
.function
.isym
!= NULL
10079 && !(expr2
->value
.function
.isym
->elemental
10080 || expr2
->value
.function
.isym
->conversion
)))
10081 lss
->is_alloc_lhs
= 1;
10084 lss
->no_bounds_check
= expr1
->no_bounds_check
;
10088 if ((expr1
->ts
.type
== BT_DERIVED
)
10089 && (gfc_is_class_array_function (expr2
)
10090 || gfc_is_alloc_class_scalar_function (expr2
)))
10091 expr2
->must_finalize
= 1;
10093 /* Checking whether a class assignment is desired is quite complicated and
10094 needed at two locations, so do it once only before the information is
10096 lhs_attr
= gfc_expr_attr (expr1
);
10097 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
10098 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
10099 && (expr1
->ts
.type
== BT_CLASS
10100 || gfc_is_class_array_ref (expr1
, NULL
)
10101 || gfc_is_class_scalar_expr (expr1
)
10102 || gfc_is_class_array_ref (expr2
, NULL
)
10103 || gfc_is_class_scalar_expr (expr2
));
10106 /* Only analyze the expressions for coarray properties, when in coarray-lib
10108 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10110 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
10111 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
10114 if (lss
!= gfc_ss_terminator
)
10116 /* The assignment needs scalarization. */
10119 /* Find a non-scalar SS from the lhs. */
10120 while (lss_section
!= gfc_ss_terminator
10121 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10122 lss_section
= lss_section
->next
;
10124 gcc_assert (lss_section
!= gfc_ss_terminator
);
10126 /* Initialize the scalarizer. */
10127 gfc_init_loopinfo (&loop
);
10129 /* Walk the rhs. */
10130 rss
= gfc_walk_expr (expr2
);
10131 if (rss
== gfc_ss_terminator
)
10132 /* The rhs is scalar. Add a ss for the expression. */
10133 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10134 /* When doing a class assign, then the handle to the rhs needs to be a
10135 pointer to allow for polymorphism. */
10136 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10137 rss
->info
->type
= GFC_SS_REFERENCE
;
10139 rss
->no_bounds_check
= expr2
->no_bounds_check
;
10140 /* Associate the SS with the loop. */
10141 gfc_add_ss_to_loop (&loop
, lss
);
10142 gfc_add_ss_to_loop (&loop
, rss
);
10144 /* Calculate the bounds of the scalarization. */
10145 gfc_conv_ss_startstride (&loop
);
10146 /* Enable loop reversal. */
10147 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10148 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10149 /* Resolve any data dependencies in the statement. */
10151 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10152 /* Setup the scalarizing loops. */
10153 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10155 /* Setup the gfc_se structures. */
10156 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10157 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10160 gfc_mark_ss_chain_used (rss
, 1);
10161 if (loop
.temp_ss
== NULL
)
10164 gfc_mark_ss_chain_used (lss
, 1);
10168 lse
.ss
= loop
.temp_ss
;
10169 gfc_mark_ss_chain_used (lss
, 3);
10170 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10173 /* Allow the scalarizer to workshare array assignments. */
10174 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10175 == OMPWS_WORKSHARE_FLAG
10176 && loop
.temp_ss
== NULL
)
10178 maybe_workshare
= true;
10179 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10182 /* Start the scalarized loop body. */
10183 gfc_start_scalarized_body (&loop
, &body
);
10186 gfc_init_block (&body
);
10188 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10190 /* Translate the expression. */
10191 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10192 && lhs_caf_attr
.codimension
;
10193 gfc_conv_expr (&rse
, expr2
);
10195 /* Deal with the case of a scalar class function assigned to a derived type. */
10196 if (gfc_is_alloc_class_scalar_function (expr2
)
10197 && expr1
->ts
.type
== BT_DERIVED
)
10199 rse
.expr
= gfc_class_data_get (rse
.expr
);
10200 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10203 /* Stabilize a string length for temporaries. */
10204 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10205 && !(VAR_P (rse
.string_length
)
10206 || TREE_CODE (rse
.string_length
) == PARM_DECL
10207 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10208 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10209 else if (expr2
->ts
.type
== BT_CHARACTER
)
10210 string_length
= rse
.string_length
;
10212 string_length
= NULL_TREE
;
10216 gfc_conv_tmp_array_ref (&lse
);
10217 if (expr2
->ts
.type
== BT_CHARACTER
)
10218 lse
.string_length
= string_length
;
10222 gfc_conv_expr (&lse
, expr1
);
10223 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10225 && gfc_expr_attr (expr1
).allocatable
10232 tmp
= INDIRECT_REF_P (lse
.expr
)
10233 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10235 /* We should only get array references here. */
10236 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10237 || TREE_CODE (tmp
) == ARRAY_REF
);
10239 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10240 or the array itself(ARRAY_REF). */
10241 tmp
= TREE_OPERAND (tmp
, 0);
10243 /* Provide the address of the array. */
10244 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10245 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10247 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10248 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10249 msg
= _("Assignment of scalar to unallocated array");
10250 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10251 &expr1
->where
, msg
);
10254 /* Deallocate the lhs parameterized components if required. */
10255 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10256 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10258 if (expr1
->ts
.type
== BT_DERIVED
10259 && expr1
->ts
.u
.derived
10260 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10262 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10264 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10266 else if (expr1
->ts
.type
== BT_CLASS
10267 && CLASS_DATA (expr1
)->ts
.u
.derived
10268 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10270 tmp
= gfc_class_data_get (lse
.expr
);
10271 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10273 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10278 /* Assignments of scalar derived types with allocatable components
10279 to arrays must be done with a deep copy and the rhs temporary
10280 must have its components deallocated afterwards. */
10281 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10282 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10283 && !gfc_expr_is_variable (expr2
)
10284 && expr1
->rank
&& !expr2
->rank
);
10285 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10287 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10288 && gfc_is_alloc_class_scalar_function (expr2
));
10289 if (scalar_to_array
&& dealloc
)
10291 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10292 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10295 /* When assigning a character function result to a deferred-length variable,
10296 the function call must happen before the (re)allocation of the lhs -
10297 otherwise the character length of the result is not known.
10298 NOTE 1: This relies on having the exact dependence of the length type
10299 parameter available to the caller; gfortran saves it in the .mod files.
10300 NOTE 2: Vector array references generate an index temporary that must
10301 not go outside the loop. Otherwise, variables should not generate
10303 NOTE 3: The concatenation operation generates a temporary pointer,
10304 whose allocation must go to the innermost loop.
10305 NOTE 4: Elemental functions may generate a temporary, too. */
10306 if (flag_realloc_lhs
10307 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10308 && !(lss
!= gfc_ss_terminator
10309 && rss
!= gfc_ss_terminator
10310 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
10311 || (expr2
->expr_type
== EXPR_FUNCTION
10312 && expr2
->value
.function
.esym
!= NULL
10313 && expr2
->value
.function
.esym
->attr
.elemental
)
10314 || (expr2
->expr_type
== EXPR_FUNCTION
10315 && expr2
->value
.function
.isym
!= NULL
10316 && expr2
->value
.function
.isym
->elemental
)
10317 || (expr2
->expr_type
== EXPR_OP
10318 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
10319 gfc_add_block_to_block (&block
, &rse
.pre
);
10321 /* Nullify the allocatable components corresponding to those of the lhs
10322 derived type, so that the finalization of the function result does not
10323 affect the lhs of the assignment. Prepend is used to ensure that the
10324 nullification occurs before the call to the finalizer. In the case of
10325 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10326 as part of the deep copy. */
10327 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10328 && (gfc_is_class_array_function (expr2
)
10329 || gfc_is_alloc_class_scalar_function (expr2
)))
10332 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10333 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10334 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10335 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10340 if (is_poly_assign
)
10341 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10342 use_vptr_copy
|| (lhs_attr
.allocatable
10343 && !lhs_attr
.dimension
),
10344 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10345 else if (flag_coarray
== GFC_FCOARRAY_LIB
10346 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10347 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10348 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10350 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10351 allocatable component, because those need to be accessed via the
10352 caf-runtime. No need to check for coindexes here, because resolve
10353 has rewritten those already. */
10355 gfc_actual_arglist a1
, a2
;
10356 /* Clear the structures to prevent accessing garbage. */
10357 memset (&code
, '\0', sizeof (gfc_code
));
10358 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10359 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10364 code
.ext
.actual
= &a1
;
10365 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10366 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10368 else if (!is_poly_assign
&& expr2
->must_finalize
10369 && expr1
->ts
.type
== BT_CLASS
10370 && expr2
->ts
.type
== BT_CLASS
)
10372 /* This case comes about when the scalarizer provides array element
10373 references. Use the vptr copy function, since this does a deep
10374 copy of allocatable components, without which the finalizer call */
10375 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
10376 if (tmp
!= NULL_TREE
)
10378 tree fcn
= gfc_vptr_copy_get (tmp
);
10379 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
10380 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
10381 tmp
= build_call_expr_loc (input_location
,
10383 gfc_build_addr_expr (NULL
, rse
.expr
),
10384 gfc_build_addr_expr (NULL
, lse
.expr
));
10388 /* If nothing else works, do it the old fashioned way! */
10389 if (tmp
== NULL_TREE
)
10390 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10391 gfc_expr_is_variable (expr2
)
10393 || expr2
->expr_type
== EXPR_ARRAY
,
10394 !(l_is_temp
|| init_flag
) && dealloc
,
10395 expr1
->symtree
->n
.sym
->attr
.codimension
);
10397 /* Add the pre blocks to the body. */
10398 gfc_add_block_to_block (&body
, &rse
.pre
);
10399 gfc_add_block_to_block (&body
, &lse
.pre
);
10400 gfc_add_expr_to_block (&body
, tmp
);
10401 /* Add the post blocks to the body. */
10402 gfc_add_block_to_block (&body
, &rse
.post
);
10403 gfc_add_block_to_block (&body
, &lse
.post
);
10405 if (lss
== gfc_ss_terminator
)
10407 /* F2003: Add the code for reallocation on assignment. */
10408 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10409 && !is_poly_assign
)
10410 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10413 /* Use the scalar assignment as is. */
10414 gfc_add_block_to_block (&block
, &body
);
10418 gcc_assert (lse
.ss
== gfc_ss_terminator
10419 && rse
.ss
== gfc_ss_terminator
);
10423 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10425 /* We need to copy the temporary to the actual lhs. */
10426 gfc_init_se (&lse
, NULL
);
10427 gfc_init_se (&rse
, NULL
);
10428 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10429 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10431 rse
.ss
= loop
.temp_ss
;
10434 gfc_conv_tmp_array_ref (&rse
);
10435 gfc_conv_expr (&lse
, expr1
);
10437 gcc_assert (lse
.ss
== gfc_ss_terminator
10438 && rse
.ss
== gfc_ss_terminator
);
10440 if (expr2
->ts
.type
== BT_CHARACTER
)
10441 rse
.string_length
= string_length
;
10443 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10445 gfc_add_expr_to_block (&body
, tmp
);
10448 /* F2003: Allocate or reallocate lhs of allocatable array. */
10449 if (flag_realloc_lhs
10450 && gfc_is_reallocatable_lhs (expr1
)
10452 && !is_runtime_conformable (expr1
, expr2
))
10454 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10455 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10456 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10457 if (tmp
!= NULL_TREE
)
10458 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10461 if (maybe_workshare
)
10462 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10464 /* Generate the copying loops. */
10465 gfc_trans_scalarizing_loops (&loop
, &body
);
10467 /* Wrap the whole thing up. */
10468 gfc_add_block_to_block (&block
, &loop
.pre
);
10469 gfc_add_block_to_block (&block
, &loop
.post
);
10471 gfc_cleanup_loop (&loop
);
10474 return gfc_finish_block (&block
);
10478 /* Check whether EXPR is a copyable array. */
10481 copyable_array_p (gfc_expr
* expr
)
10483 if (expr
->expr_type
!= EXPR_VARIABLE
)
10486 /* First check it's an array. */
10487 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10490 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10493 /* Next check that it's of a simple enough type. */
10494 switch (expr
->ts
.type
)
10506 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10515 /* Translate an assignment. */
10518 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10519 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10523 /* Special case a single function returning an array. */
10524 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10526 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10531 /* Special case assigning an array to zero. */
10532 if (copyable_array_p (expr1
)
10533 && is_zero_initializer_p (expr2
))
10535 tmp
= gfc_trans_zero_assign (expr1
);
10540 /* Special case copying one array to another. */
10541 if (copyable_array_p (expr1
)
10542 && copyable_array_p (expr2
)
10543 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10544 && !gfc_check_dependency (expr1
, expr2
, 0))
10546 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10551 /* Special case initializing an array from a constant array constructor. */
10552 if (copyable_array_p (expr1
)
10553 && expr2
->expr_type
== EXPR_ARRAY
10554 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10556 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10561 if (UNLIMITED_POLY (expr1
) && expr1
->rank
10562 && expr2
->ts
.type
!= BT_CLASS
)
10563 use_vptr_copy
= true;
10565 /* Fallback to the scalarizer to generate explicit loops. */
10566 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10567 use_vptr_copy
, may_alias
);
10571 gfc_trans_init_assign (gfc_code
* code
)
10573 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10577 gfc_trans_assign (gfc_code
* code
)
10579 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);