1 /* Expression translation
2 Copyright (C) 2002-2016 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
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (CONSTANT_CLASS_P (scalar
))
78 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
79 gfc_add_modify (&se
->pre
, tmp
, scalar
);
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
83 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
84 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
85 gfc_get_dtype (type
));
86 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
91 gfc_add_modify (&se
->post
, scalar
,
92 fold_convert (TREE_TYPE (scalar
),
93 gfc_conv_descriptor_data_get (desc
)));
98 /* Get the coarray token from the ultimate array or component ref.
99 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
102 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
104 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
105 bool is_coarray
= sym
->attr
.codimension
;
106 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
107 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
111 if (ref
->type
== REF_COMPONENT
112 && (ref
->u
.c
.component
->attr
.allocatable
113 || ref
->u
.c
.component
->attr
.pointer
)
114 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
119 if (last_caf_ref
== NULL
)
122 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
124 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
125 if (comp
== NULL_TREE
&& comp_ref
)
127 gfc_init_se (&se
, outerse
);
128 gfc_free_ref_list (last_caf_ref
->next
);
129 last_caf_ref
->next
= NULL
;
130 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
131 se
.want_pointer
= comp_ref
;
132 gfc_conv_expr (&se
, caf_expr
);
133 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
135 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
136 se
.expr
= TREE_OPERAND (se
.expr
, 0);
137 gfc_free_expr (caf_expr
);
140 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
141 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
143 caf
= gfc_conv_descriptor_token (se
.expr
);
144 return gfc_build_addr_expr (NULL_TREE
, caf
);
148 /* This is the seed for an eventual trans-class.c
150 The following parameters should not be used directly since they might
151 in future implementations. Use the corresponding APIs. */
152 #define CLASS_DATA_FIELD 0
153 #define CLASS_VPTR_FIELD 1
154 #define CLASS_LEN_FIELD 2
155 #define VTABLE_HASH_FIELD 0
156 #define VTABLE_SIZE_FIELD 1
157 #define VTABLE_EXTENDS_FIELD 2
158 #define VTABLE_DEF_INIT_FIELD 3
159 #define VTABLE_COPY_FIELD 4
160 #define VTABLE_FINAL_FIELD 5
161 #define VTABLE_DEALLOCATE_FIELD 6
165 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
169 vec
<constructor_elt
, va_gc
> *init
= NULL
;
171 field
= TYPE_FIELDS (TREE_TYPE (decl
));
172 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
173 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
175 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
178 return build_constructor (TREE_TYPE (decl
), init
);
183 gfc_class_data_get (tree decl
)
186 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
187 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
188 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
190 return fold_build3_loc (input_location
, COMPONENT_REF
,
191 TREE_TYPE (data
), decl
, data
,
197 gfc_class_vptr_get (tree decl
)
200 /* For class arrays decl may be a temporary descriptor handle, the vptr is
201 then available through the saved descriptor. */
202 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
204 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
205 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
206 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
207 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
209 return fold_build3_loc (input_location
, COMPONENT_REF
,
210 TREE_TYPE (vptr
), decl
, vptr
,
216 gfc_class_len_get (tree decl
)
219 /* For class arrays decl may be a temporary descriptor handle, the len is
220 then available through the saved descriptor. */
221 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
222 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
223 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
224 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
225 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
226 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
228 return fold_build3_loc (input_location
, COMPONENT_REF
,
229 TREE_TYPE (len
), decl
, len
,
234 /* Try to get the _len component of a class. When the class is not unlimited
235 poly, i.e. no _len field exists, then return a zero node. */
238 gfc_class_len_or_zero_get (tree decl
)
241 /* For class arrays decl may be a temporary descriptor handle, the vptr is
242 then available through the saved descriptor. */
243 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
244 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
245 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
246 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
247 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
248 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
250 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
251 TREE_TYPE (len
), decl
, len
,
257 /* Get the specified FIELD from the VPTR. */
260 vptr_field_get (tree vptr
, int fieldno
)
263 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
264 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
266 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
267 TREE_TYPE (field
), vptr
, field
,
274 /* Get the field from the class' vptr. */
277 class_vtab_field_get (tree decl
, int fieldno
)
280 vptr
= gfc_class_vptr_get (decl
);
281 return vptr_field_get (vptr
, fieldno
);
285 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
287 #define VTAB_GET_FIELD_GEN(name, field) tree \
288 gfc_class_vtab_## name ##_get (tree cl) \
290 return class_vtab_field_get (cl, field); \
294 gfc_vptr_## name ##_get (tree vptr) \
296 return vptr_field_get (vptr, field); \
299 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
300 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
301 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
302 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
303 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
304 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
307 /* The size field is returned as an array index type. Therefore treat
308 it and only it specially. */
311 gfc_class_vtab_size_get (tree cl
)
314 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
315 /* Always return size as an array index type. */
316 size
= fold_convert (gfc_array_index_type
, size
);
322 gfc_vptr_size_get (tree vptr
)
325 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
326 /* Always return size as an array index type. */
327 size
= fold_convert (gfc_array_index_type
, size
);
333 #undef CLASS_DATA_FIELD
334 #undef CLASS_VPTR_FIELD
335 #undef CLASS_LEN_FIELD
336 #undef VTABLE_HASH_FIELD
337 #undef VTABLE_SIZE_FIELD
338 #undef VTABLE_EXTENDS_FIELD
339 #undef VTABLE_DEF_INIT_FIELD
340 #undef VTABLE_COPY_FIELD
341 #undef VTABLE_FINAL_FIELD
344 /* Search for the last _class ref in the chain of references of this
345 expression and cut the chain there. Albeit this routine is similiar
346 to class.c::gfc_add_component_ref (), is there a significant
347 difference: gfc_add_component_ref () concentrates on an array ref to
348 be the last ref in the chain. This routine is oblivious to the kind
349 of refs following. */
352 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
355 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
357 /* Find the last class reference. */
360 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
362 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
365 if (ref
->type
== REF_COMPONENT
366 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
368 /* Component to the right of a part reference with nonzero rank
369 must not have the ALLOCATABLE attribute. If attempts are
370 made to reference such a component reference, an error results
371 followed by an ICE. */
372 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
377 if (ref
->next
== NULL
)
381 /* Remove and store all subsequent references after the
385 tail
= class_ref
->next
;
386 class_ref
->next
= NULL
;
388 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
394 base_expr
= gfc_expr_to_initialize (e
);
396 /* Restore the original tail expression. */
399 gfc_free_ref_list (class_ref
->next
);
400 class_ref
->next
= tail
;
402 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
404 gfc_free_ref_list (e
->ref
);
411 /* Reset the vptr to the declared type, e.g. after deallocation. */
414 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
421 /* Evaluate the expression and obtain the vptr from it. */
422 gfc_init_se (&se
, NULL
);
424 gfc_conv_expr_descriptor (&se
, e
);
426 gfc_conv_expr (&se
, e
);
427 gfc_add_block_to_block (block
, &se
.pre
);
428 vptr
= gfc_get_vptr_from_expr (se
.expr
);
430 /* If a vptr is not found, we can do nothing more. */
431 if (vptr
== NULL_TREE
)
434 if (UNLIMITED_POLY (e
))
435 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
438 /* Return the vptr to the address of the declared type. */
439 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
440 vtable
= vtab
->backend_decl
;
441 if (vtable
== NULL_TREE
)
442 vtable
= gfc_get_symbol_decl (vtab
);
443 vtable
= gfc_build_addr_expr (NULL
, vtable
);
444 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
445 gfc_add_modify (block
, vptr
, vtable
);
450 /* Reset the len for unlimited polymorphic objects. */
453 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
457 e
= gfc_find_and_cut_at_last_class_ref (expr
);
460 gfc_add_len_component (e
);
461 gfc_init_se (&se_len
, NULL
);
462 gfc_conv_expr (&se_len
, e
);
463 gfc_add_modify (block
, se_len
.expr
,
464 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
469 /* Obtain the vptr of the last class reference in an expression.
470 Return NULL_TREE if no class reference is found. */
473 gfc_get_vptr_from_expr (tree expr
)
478 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
480 type
= TREE_TYPE (tmp
);
483 if (GFC_CLASS_TYPE_P (type
))
484 return gfc_class_vptr_get (tmp
);
485 if (type
!= TYPE_CANONICAL (type
))
486 type
= TYPE_CANONICAL (type
);
490 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
494 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
495 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
497 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
498 return gfc_class_vptr_get (tmp
);
505 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
508 tree tmp
, tmp2
, type
;
510 gfc_conv_descriptor_data_set (block
, lhs_desc
,
511 gfc_conv_descriptor_data_get (rhs_desc
));
512 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
513 gfc_conv_descriptor_offset_get (rhs_desc
));
515 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
516 gfc_conv_descriptor_dtype (rhs_desc
));
518 /* Assign the dimension as range-ref. */
519 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
520 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
522 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
523 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
524 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
525 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
526 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
527 gfc_add_modify (block
, tmp
, tmp2
);
531 /* Takes a derived type expression and returns the address of a temporary
532 class object of the 'declared' type. If vptr is not NULL, this is
533 used for the temporary class object.
534 optional_alloc_ptr is false when the dummy is neither allocatable
535 nor a pointer; that's only relevant for the optional handling. */
537 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
538 gfc_typespec class_ts
, tree vptr
, bool optional
,
539 bool optional_alloc_ptr
)
542 tree cond_optional
= NULL_TREE
;
548 /* The derived type needs to be converted to a temporary
550 tmp
= gfc_typenode_for_spec (&class_ts
);
551 var
= gfc_create_var (tmp
, "class");
554 ctree
= gfc_class_vptr_get (var
);
556 if (vptr
!= NULL_TREE
)
558 /* Use the dynamic vptr. */
563 /* In this case the vtab corresponds to the derived type and the
564 vptr must point to it. */
565 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
567 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
569 gfc_add_modify (&parmse
->pre
, ctree
,
570 fold_convert (TREE_TYPE (ctree
), tmp
));
572 /* Now set the data field. */
573 ctree
= gfc_class_data_get (var
);
576 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
578 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
580 /* If there is a ready made pointer to a derived type, use it
581 rather than evaluating the expression again. */
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
585 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
587 /* For an array reference in an elemental procedure call we need
588 to retain the ss to provide the scalarized array reference. */
589 gfc_conv_expr_reference (parmse
, e
);
590 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
592 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
594 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
595 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
599 ss
= gfc_walk_expr (e
);
600 if (ss
== gfc_ss_terminator
)
603 gfc_conv_expr_reference (parmse
, e
);
605 /* Scalar to an assumed-rank array. */
606 if (class_ts
.u
.derived
->components
->as
)
609 type
= get_scalar_to_descriptor_type (parmse
->expr
,
611 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
612 gfc_get_dtype (type
));
614 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
615 TREE_TYPE (parmse
->expr
),
616 cond_optional
, parmse
->expr
,
617 fold_convert (TREE_TYPE (parmse
->expr
),
619 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
623 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
625 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
627 fold_convert (TREE_TYPE (tmp
),
629 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
635 gfc_init_block (&block
);
638 gfc_conv_expr_descriptor (parmse
, e
);
640 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
642 gcc_assert (class_ts
.u
.derived
->components
->as
->type
644 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
648 if (gfc_expr_attr (e
).codimension
)
649 parmse
->expr
= fold_build1_loc (input_location
,
653 gfc_add_modify (&block
, ctree
, parmse
->expr
);
658 tmp
= gfc_finish_block (&block
);
660 gfc_init_block (&block
);
661 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
663 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
664 gfc_finish_block (&block
));
665 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
668 gfc_add_block_to_block (&parmse
->pre
, &block
);
672 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
673 && class_ts
.u
.derived
->components
->ts
.u
.derived
674 ->attr
.unlimited_polymorphic
)
676 /* Take care about initializing the _len component correctly. */
677 ctree
= gfc_class_len_get (var
);
678 if (UNLIMITED_POLY (e
))
683 len
= gfc_copy_expr (e
);
684 gfc_add_len_component (len
);
685 gfc_init_se (&se
, NULL
);
686 gfc_conv_expr (&se
, len
);
688 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
689 cond_optional
, se
.expr
,
690 fold_convert (TREE_TYPE (se
.expr
),
696 tmp
= integer_zero_node
;
697 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
700 /* Pass the address of the class object. */
701 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
703 if (optional
&& optional_alloc_ptr
)
704 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
705 TREE_TYPE (parmse
->expr
),
706 cond_optional
, parmse
->expr
,
707 fold_convert (TREE_TYPE (parmse
->expr
),
712 /* Create a new class container, which is required as scalar coarrays
713 have an array descriptor while normal scalars haven't. Optionally,
714 NULL pointer checks are added if the argument is OPTIONAL. */
717 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
718 gfc_typespec class_ts
, bool optional
)
720 tree var
, ctree
, tmp
;
725 gfc_init_block (&block
);
728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
730 if (ref
->type
== REF_COMPONENT
731 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 var
= gfc_typenode_for_spec (&class_ts
);
752 var
= gfc_create_var (var
, "class");
754 ctree
= gfc_class_vptr_get (var
);
755 gfc_add_modify (&block
, ctree
,
756 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
758 ctree
= gfc_class_data_get (var
);
759 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
760 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
762 /* Pass the address of the class object. */
763 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
767 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
770 tmp
= gfc_finish_block (&block
);
772 gfc_init_block (&block
);
773 tmp2
= gfc_class_data_get (var
);
774 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
776 tmp2
= gfc_finish_block (&block
);
778 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
780 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
783 gfc_add_block_to_block (&parmse
->pre
, &block
);
787 /* Takes an intrinsic type expression and returns the address of a temporary
788 class object of the 'declared' type. */
790 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
791 gfc_typespec class_ts
)
799 /* The intrinsic type needs to be converted to a temporary
801 tmp
= gfc_typenode_for_spec (&class_ts
);
802 var
= gfc_create_var (tmp
, "class");
805 ctree
= gfc_class_vptr_get (var
);
807 vtab
= gfc_find_vtab (&e
->ts
);
809 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
810 gfc_add_modify (&parmse
->pre
, ctree
,
811 fold_convert (TREE_TYPE (ctree
), tmp
));
813 /* Now set the data field. */
814 ctree
= gfc_class_data_get (var
);
815 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
817 /* For an array reference in an elemental procedure call we need
818 to retain the ss to provide the scalarized array reference. */
819 gfc_conv_expr_reference (parmse
, e
);
820 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
821 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
825 ss
= gfc_walk_expr (e
);
826 if (ss
== gfc_ss_terminator
)
829 gfc_conv_expr_reference (parmse
, e
);
830 if (class_ts
.u
.derived
->components
->as
831 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
833 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
835 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
836 TREE_TYPE (ctree
), tmp
);
839 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
840 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
845 parmse
->use_offset
= 1;
846 gfc_conv_expr_descriptor (parmse
, e
);
847 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
849 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
850 TREE_TYPE (ctree
), parmse
->expr
);
851 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
854 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
858 gcc_assert (class_ts
.type
== BT_CLASS
);
859 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
860 && class_ts
.u
.derived
->components
->ts
.u
.derived
861 ->attr
.unlimited_polymorphic
)
863 ctree
= gfc_class_len_get (var
);
864 /* When the actual arg is a char array, then set the _len component of the
865 unlimited polymorphic entity to the length of the string. */
866 if (e
->ts
.type
== BT_CHARACTER
)
868 /* Start with parmse->string_length because this seems to be set to a
869 correct value more often. */
870 if (parmse
->string_length
)
871 tmp
= parmse
->string_length
;
872 /* When the string_length is not yet set, then try the backend_decl of
874 else if (e
->ts
.u
.cl
->backend_decl
)
875 tmp
= e
->ts
.u
.cl
->backend_decl
;
876 /* If both of the above approaches fail, then try to generate an
877 expression from the input, which is only feasible currently, when the
878 expression can be evaluated to a constant one. */
881 /* Try to simplify the expression. */
882 gfc_simplify_expr (e
, 0);
883 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
885 /* Amazingly all data is present to compute the length of a
886 constant string, but the expression is not yet there. */
887 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
889 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
890 e
->value
.character
.length
);
891 gfc_conv_const_charlen (e
->ts
.u
.cl
);
892 e
->ts
.u
.cl
->resolved
= 1;
893 tmp
= e
->ts
.u
.cl
->backend_decl
;
897 gfc_error ("Can't compute the length of the char array at %L.",
903 tmp
= integer_zero_node
;
905 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
907 else if (class_ts
.type
== BT_CLASS
908 && class_ts
.u
.derived
->components
909 && class_ts
.u
.derived
->components
->ts
.u
910 .derived
->attr
.unlimited_polymorphic
)
912 ctree
= gfc_class_len_get (var
);
913 gfc_add_modify (&parmse
->pre
, ctree
,
914 fold_convert (TREE_TYPE (ctree
),
917 /* Pass the address of the class object. */
918 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
922 /* Takes a scalarized class array expression and returns the
923 address of a temporary scalar class object of the 'declared'
925 OOP-TODO: This could be improved by adding code that branched on
926 the dynamic type being the same as the declared type. In this case
927 the original class expression can be passed directly.
928 optional_alloc_ptr is false when the dummy is neither allocatable
929 nor a pointer; that's relevant for the optional handling.
930 Set copyback to true if class container's _data and _vtab pointers
931 might get modified. */
934 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
935 bool elemental
, bool copyback
, bool optional
,
936 bool optional_alloc_ptr
)
942 tree cond
= NULL_TREE
;
943 tree slen
= NULL_TREE
;
947 bool full_array
= false;
949 gfc_init_block (&block
);
952 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
954 if (ref
->type
== REF_COMPONENT
955 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
958 if (ref
->next
== NULL
)
962 if ((ref
== NULL
|| class_ref
== ref
)
963 && (!class_ts
.u
.derived
->components
->as
964 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
967 /* Test for FULL_ARRAY. */
968 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
969 && gfc_expr_attr (e
).dimension
)
972 gfc_is_class_array_ref (e
, &full_array
);
974 /* The derived type needs to be converted to a temporary
976 tmp
= gfc_typenode_for_spec (&class_ts
);
977 var
= gfc_create_var (tmp
, "class");
980 ctree
= gfc_class_data_get (var
);
981 if (class_ts
.u
.derived
->components
->as
982 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
986 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
988 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
989 gfc_get_dtype (type
));
991 tmp
= gfc_class_data_get (parmse
->expr
);
992 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
993 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
995 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
998 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1002 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1003 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1004 TREE_TYPE (ctree
), parmse
->expr
);
1005 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1008 /* Return the data component, except in the case of scalarized array
1009 references, where nullification of the cannot occur and so there
1011 if (!elemental
&& full_array
&& copyback
)
1013 if (class_ts
.u
.derived
->components
->as
1014 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1017 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1018 gfc_conv_descriptor_data_get (ctree
));
1020 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1023 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1027 ctree
= gfc_class_vptr_get (var
);
1029 /* The vptr is the second field of the actual argument.
1030 First we have to find the corresponding class reference. */
1033 if (class_ref
== NULL
1034 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1036 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1038 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1039 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1041 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1042 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1044 slen
= integer_zero_node
;
1048 /* Remove everything after the last class reference, convert the
1049 expression and then recover its tailend once more. */
1051 ref
= class_ref
->next
;
1052 class_ref
->next
= NULL
;
1053 gfc_init_se (&tmpse
, NULL
);
1054 gfc_conv_expr (&tmpse
, e
);
1055 class_ref
->next
= ref
;
1057 slen
= tmpse
.string_length
;
1060 gcc_assert (tmp
!= NULL_TREE
);
1062 /* Dereference if needs be. */
1063 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1064 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1066 vptr
= gfc_class_vptr_get (tmp
);
1067 gfc_add_modify (&block
, ctree
,
1068 fold_convert (TREE_TYPE (ctree
), vptr
));
1070 /* Return the vptr component, except in the case of scalarized array
1071 references, where the dynamic type cannot change. */
1072 if (!elemental
&& full_array
&& copyback
)
1073 gfc_add_modify (&parmse
->post
, vptr
,
1074 fold_convert (TREE_TYPE (vptr
), ctree
));
1076 /* For unlimited polymorphic objects also set the _len component. */
1077 if (class_ts
.type
== BT_CLASS
1078 && class_ts
.u
.derived
->components
1079 && class_ts
.u
.derived
->components
->ts
.u
1080 .derived
->attr
.unlimited_polymorphic
)
1082 ctree
= gfc_class_len_get (var
);
1083 if (UNLIMITED_POLY (e
))
1084 tmp
= gfc_class_len_get (tmp
);
1085 else if (e
->ts
.type
== BT_CHARACTER
)
1087 gcc_assert (slen
!= NULL_TREE
);
1091 tmp
= integer_zero_node
;
1092 gfc_add_modify (&parmse
->pre
, ctree
,
1093 fold_convert (TREE_TYPE (ctree
), tmp
));
1095 /* Return the len component, except in the case of scalarized array
1096 references, where the dynamic type cannot change. */
1097 if (!elemental
&& full_array
&& copyback
)
1098 gfc_add_modify (&parmse
->post
, tmp
,
1099 fold_convert (TREE_TYPE (tmp
), ctree
));
1106 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1107 /* parmse->pre may contain some preparatory instructions for the
1108 temporary array descriptor. Those may only be executed when the
1109 optional argument is set, therefore add parmse->pre's instructions
1110 to block, which is later guarded by an if (optional_arg_given). */
1111 gfc_add_block_to_block (&parmse
->pre
, &block
);
1112 block
.head
= parmse
->pre
.head
;
1113 parmse
->pre
.head
= NULL_TREE
;
1114 tmp
= gfc_finish_block (&block
);
1116 if (optional_alloc_ptr
)
1117 tmp2
= build_empty_stmt (input_location
);
1120 gfc_init_block (&block
);
1122 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1123 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1124 null_pointer_node
));
1125 tmp2
= gfc_finish_block (&block
);
1128 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1130 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1133 gfc_add_block_to_block (&parmse
->pre
, &block
);
1135 /* Pass the address of the class object. */
1136 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1138 if (optional
&& optional_alloc_ptr
)
1139 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1140 TREE_TYPE (parmse
->expr
),
1142 fold_convert (TREE_TYPE (parmse
->expr
),
1143 null_pointer_node
));
1147 /* Given a class array declaration and an index, returns the address
1148 of the referenced element. */
1151 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1153 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1154 gfc_class_data_get (class_decl
);
1155 tree size
= gfc_class_vtab_size_get (class_decl
);
1156 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1157 gfc_array_index_type
,
1160 data
= gfc_conv_descriptor_data_get (data
);
1161 ptr
= fold_convert (pvoid_type_node
, data
);
1162 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1163 return fold_convert (TREE_TYPE (data
), ptr
);
1167 /* Copies one class expression to another, assuming that if either
1168 'to' or 'from' are arrays they are packed. Should 'from' be
1169 NULL_TREE, the initialization expression for 'to' is used, assuming
1170 that the _vptr is set. */
1173 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1183 vec
<tree
, va_gc
> *args
;
1188 bool is_from_desc
= false, is_to_class
= false;
1191 /* To prevent warnings on uninitialized variables. */
1192 from_len
= to_len
= NULL_TREE
;
1194 if (from
!= NULL_TREE
)
1195 fcn
= gfc_class_vtab_copy_get (from
);
1197 fcn
= gfc_class_vtab_copy_get (to
);
1199 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1201 if (from
!= NULL_TREE
)
1203 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1207 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1211 /* Check that from is a class. When the class is part of a coarray,
1212 then from is a common pointer and is to be used as is. */
1213 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1214 ? build_fold_indirect_ref (from
) : from
;
1216 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1217 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1218 ? gfc_class_data_get (from
) : from
;
1219 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1223 from_data
= gfc_class_vtab_def_init_get (to
);
1227 if (from
!= NULL_TREE
&& unlimited
)
1228 from_len
= gfc_class_len_or_zero_get (from
);
1230 from_len
= integer_zero_node
;
1233 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1236 to_data
= gfc_class_data_get (to
);
1238 to_len
= gfc_class_len_get (to
);
1241 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1244 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1246 stmtblock_t loopbody
;
1250 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1252 gfc_init_block (&body
);
1253 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1254 gfc_array_index_type
, nelems
,
1255 gfc_index_one_node
);
1256 nelems
= gfc_evaluate_now (tmp
, &body
);
1257 index
= gfc_create_var (gfc_array_index_type
, "S");
1261 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1262 vec_safe_push (args
, from_ref
);
1265 vec_safe_push (args
, from_data
);
1268 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1271 tmp
= gfc_conv_array_data (to
);
1272 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1273 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1274 gfc_build_array_ref (tmp
, index
, to
));
1276 vec_safe_push (args
, to_ref
);
1278 /* Add bounds check. */
1279 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1282 const char *name
= "<<unknown>>";
1286 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1288 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1289 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1290 boolean_type_node
, from_len
, orig_nelems
);
1291 msg
= xasprintf ("Array bound mismatch for dimension %d "
1292 "of array '%s' (%%ld/%%ld)",
1295 gfc_trans_runtime_check (true, false, tmp
, &body
,
1296 &gfc_current_locus
, msg
,
1297 fold_convert (long_integer_type_node
, orig_nelems
),
1298 fold_convert (long_integer_type_node
, from_len
));
1303 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1305 /* Build the body of the loop. */
1306 gfc_init_block (&loopbody
);
1307 gfc_add_expr_to_block (&loopbody
, tmp
);
1309 /* Build the loop and return. */
1310 gfc_init_loopinfo (&loop
);
1312 loop
.from
[0] = gfc_index_zero_node
;
1313 loop
.loopvar
[0] = index
;
1314 loop
.to
[0] = nelems
;
1315 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1316 gfc_init_block (&ifbody
);
1317 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1318 stdcopy
= gfc_finish_block (&ifbody
);
1319 /* In initialization mode from_len is a constant zero. */
1320 if (unlimited
&& !integer_zerop (from_len
))
1322 vec_safe_push (args
, from_len
);
1323 vec_safe_push (args
, to_len
);
1324 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1325 /* Build the body of the loop. */
1326 gfc_init_block (&loopbody
);
1327 gfc_add_expr_to_block (&loopbody
, tmp
);
1329 /* Build the loop and return. */
1330 gfc_init_loopinfo (&loop
);
1332 loop
.from
[0] = gfc_index_zero_node
;
1333 loop
.loopvar
[0] = index
;
1334 loop
.to
[0] = nelems
;
1335 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1336 gfc_init_block (&ifbody
);
1337 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1338 extcopy
= gfc_finish_block (&ifbody
);
1340 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1341 boolean_type_node
, from_len
,
1343 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1344 void_type_node
, tmp
, extcopy
, stdcopy
);
1345 gfc_add_expr_to_block (&body
, tmp
);
1346 tmp
= gfc_finish_block (&body
);
1350 gfc_add_expr_to_block (&body
, stdcopy
);
1351 tmp
= gfc_finish_block (&body
);
1353 gfc_cleanup_loop (&loop
);
1357 gcc_assert (!is_from_desc
);
1358 vec_safe_push (args
, from_data
);
1359 vec_safe_push (args
, to_data
);
1360 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1362 /* In initialization mode from_len is a constant zero. */
1363 if (unlimited
&& !integer_zerop (from_len
))
1365 vec_safe_push (args
, from_len
);
1366 vec_safe_push (args
, to_len
);
1367 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1368 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1369 boolean_type_node
, from_len
,
1371 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1372 void_type_node
, tmp
, extcopy
, stdcopy
);
1378 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1379 if (from
== NULL_TREE
)
1382 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1384 from_data
, null_pointer_node
);
1385 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1386 void_type_node
, cond
,
1387 tmp
, build_empty_stmt (input_location
));
1395 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1397 gfc_actual_arglist
*actual
;
1402 actual
= gfc_get_actual_arglist ();
1403 actual
->expr
= gfc_copy_expr (rhs
);
1404 actual
->next
= gfc_get_actual_arglist ();
1405 actual
->next
->expr
= gfc_copy_expr (lhs
);
1406 ppc
= gfc_copy_expr (obj
);
1407 gfc_add_vptr_component (ppc
);
1408 gfc_add_component_ref (ppc
, "_copy");
1409 ppc_code
= gfc_get_code (EXEC_CALL
);
1410 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1411 /* Although '_copy' is set to be elemental in class.c, it is
1412 not staying that way. Find out why, sometime.... */
1413 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1414 ppc_code
->ext
.actual
= actual
;
1415 ppc_code
->expr1
= ppc
;
1416 /* Since '_copy' is elemental, the scalarizer will take care
1417 of arrays in gfc_trans_call. */
1418 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1419 gfc_free_statements (ppc_code
);
1421 if (UNLIMITED_POLY(obj
))
1423 /* Check if rhs is non-NULL. */
1425 gfc_init_se (&src
, NULL
);
1426 gfc_conv_expr (&src
, rhs
);
1427 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1428 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1429 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1430 null_pointer_node
));
1431 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1432 build_empty_stmt (input_location
));
1438 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1439 A MEMCPY is needed to copy the full data from the default initializer
1440 of the dynamic type. */
1443 gfc_trans_class_init_assign (gfc_code
*code
)
1447 gfc_se dst
,src
,memsz
;
1448 gfc_expr
*lhs
, *rhs
, *sz
;
1450 gfc_start_block (&block
);
1452 lhs
= gfc_copy_expr (code
->expr1
);
1453 gfc_add_data_component (lhs
);
1455 rhs
= gfc_copy_expr (code
->expr1
);
1456 gfc_add_vptr_component (rhs
);
1458 /* Make sure that the component backend_decls have been built, which
1459 will not have happened if the derived types concerned have not
1461 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1462 gfc_add_def_init_component (rhs
);
1463 /* The _def_init is always scalar. */
1466 if (code
->expr1
->ts
.type
== BT_CLASS
1467 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1469 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1470 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1471 gfc_add_full_array_ref (lhs
, tmparr
);
1472 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1476 sz
= gfc_copy_expr (code
->expr1
);
1477 gfc_add_vptr_component (sz
);
1478 gfc_add_size_component (sz
);
1480 gfc_init_se (&dst
, NULL
);
1481 gfc_init_se (&src
, NULL
);
1482 gfc_init_se (&memsz
, NULL
);
1483 gfc_conv_expr (&dst
, lhs
);
1484 gfc_conv_expr (&src
, rhs
);
1485 gfc_conv_expr (&memsz
, sz
);
1486 gfc_add_block_to_block (&block
, &src
.pre
);
1487 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1489 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1491 if (UNLIMITED_POLY(code
->expr1
))
1493 /* Check if _def_init is non-NULL. */
1494 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1495 boolean_type_node
, src
.expr
,
1496 fold_convert (TREE_TYPE (src
.expr
),
1497 null_pointer_node
));
1498 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1499 tmp
, build_empty_stmt (input_location
));
1503 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1504 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1506 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1507 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1509 build_empty_stmt (input_location
));
1512 gfc_add_expr_to_block (&block
, tmp
);
1514 return gfc_finish_block (&block
);
1518 /* End of prototype trans-class.c */
1522 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1524 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1525 gfc_warning (OPT_Wrealloc_lhs
,
1526 "Code for reallocating the allocatable array at %L will "
1528 else if (warn_realloc_lhs_all
)
1529 gfc_warning (OPT_Wrealloc_lhs_all
,
1530 "Code for reallocating the allocatable variable at %L "
1531 "will be added", where
);
1535 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1538 /* Copy the scalarization loop variables. */
1541 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1544 dest
->loop
= src
->loop
;
1548 /* Initialize a simple expression holder.
1550 Care must be taken when multiple se are created with the same parent.
1551 The child se must be kept in sync. The easiest way is to delay creation
1552 of a child se until after after the previous se has been translated. */
1555 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1557 memset (se
, 0, sizeof (gfc_se
));
1558 gfc_init_block (&se
->pre
);
1559 gfc_init_block (&se
->post
);
1561 se
->parent
= parent
;
1564 gfc_copy_se_loopvars (se
, parent
);
1568 /* Advances to the next SS in the chain. Use this rather than setting
1569 se->ss = se->ss->next because all the parents needs to be kept in sync.
1573 gfc_advance_se_ss_chain (gfc_se
* se
)
1578 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1581 /* Walk down the parent chain. */
1584 /* Simple consistency check. */
1585 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1586 || p
->parent
->ss
->nested_ss
== p
->ss
);
1588 /* If we were in a nested loop, the next scalarized expression can be
1589 on the parent ss' next pointer. Thus we should not take the next
1590 pointer blindly, but rather go up one nest level as long as next
1591 is the end of chain. */
1593 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1603 /* Ensures the result of the expression as either a temporary variable
1604 or a constant so that it can be used repeatedly. */
1607 gfc_make_safe_expr (gfc_se
* se
)
1611 if (CONSTANT_CLASS_P (se
->expr
))
1614 /* We need a temporary for this result. */
1615 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1616 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1621 /* Return an expression which determines if a dummy parameter is present.
1622 Also used for arguments to procedures with multiple entry points. */
1625 gfc_conv_expr_present (gfc_symbol
* sym
)
1629 gcc_assert (sym
->attr
.dummy
);
1630 decl
= gfc_get_symbol_decl (sym
);
1632 /* Intrinsic scalars with VALUE attribute which are passed by value
1633 use a hidden argument to denote the present status. */
1634 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1635 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1636 && !sym
->attr
.dimension
)
1638 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1641 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1643 strcpy (&name
[1], sym
->name
);
1644 tree_name
= get_identifier (name
);
1646 /* Walk function argument list to find hidden arg. */
1647 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1648 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1649 if (DECL_NAME (cond
) == tree_name
)
1656 if (TREE_CODE (decl
) != PARM_DECL
)
1658 /* Array parameters use a temporary descriptor, we want the real
1660 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1661 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1662 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1665 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1666 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1668 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1669 as actual argument to denote absent dummies. For array descriptors,
1670 we thus also need to check the array descriptor. For BT_CLASS, it
1671 can also occur for scalars and F2003 due to type->class wrapping and
1672 class->class wrapping. Note further that BT_CLASS always uses an
1673 array descriptor for arrays, also for explicit-shape/assumed-size. */
1675 if (!sym
->attr
.allocatable
1676 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1677 || (sym
->ts
.type
== BT_CLASS
1678 && !CLASS_DATA (sym
)->attr
.allocatable
1679 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1680 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1681 || sym
->ts
.type
== BT_CLASS
))
1685 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1686 || sym
->as
->type
== AS_ASSUMED_RANK
1687 || sym
->attr
.codimension
))
1688 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1690 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1691 if (sym
->ts
.type
== BT_CLASS
)
1692 tmp
= gfc_class_data_get (tmp
);
1693 tmp
= gfc_conv_array_data (tmp
);
1695 else if (sym
->ts
.type
== BT_CLASS
)
1696 tmp
= gfc_class_data_get (decl
);
1700 if (tmp
!= NULL_TREE
)
1702 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1703 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1704 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1705 boolean_type_node
, cond
, tmp
);
1713 /* Converts a missing, dummy argument into a null or zero. */
1716 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1721 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1725 /* Create a temporary and convert it to the correct type. */
1726 tmp
= gfc_get_int_type (kind
);
1727 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1730 /* Test for a NULL value. */
1731 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1732 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1733 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1734 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1738 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1740 build_zero_cst (TREE_TYPE (se
->expr
)));
1741 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1745 if (ts
.type
== BT_CHARACTER
)
1747 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1748 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1749 present
, se
->string_length
, tmp
);
1750 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1751 se
->string_length
= tmp
;
1757 /* Get the character length of an expression, looking through gfc_refs
1761 gfc_get_expr_charlen (gfc_expr
*e
)
1766 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1767 && e
->ts
.type
== BT_CHARACTER
);
1769 length
= NULL
; /* To silence compiler warning. */
1771 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1774 gfc_init_se (&tmpse
, NULL
);
1775 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1776 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1780 /* First candidate: if the variable is of type CHARACTER, the
1781 expression's length could be the length of the character
1783 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1784 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1786 /* Look through the reference chain for component references. */
1787 for (r
= e
->ref
; r
; r
= r
->next
)
1792 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1793 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1801 /* We should never got substring references here. These will be
1802 broken down by the scalarizer. */
1808 gcc_assert (length
!= NULL
);
1813 /* Return for an expression the backend decl of the coarray. */
1816 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1822 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1824 /* Not-implemented diagnostic. */
1825 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1826 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1827 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1828 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1829 "%L is not supported", &expr
->where
);
1831 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1832 if (ref
->type
== REF_COMPONENT
)
1834 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1835 && UNLIMITED_POLY (ref
->u
.c
.component
)
1836 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1837 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1838 "component at %L is not supported", &expr
->where
);
1841 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1842 gcc_assert (caf_decl
);
1843 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1845 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1847 caf_decl
= gfc_class_data_get (caf_decl
);
1848 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1851 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1853 if (ref
->type
== REF_COMPONENT
1854 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1856 caf_decl
= gfc_class_data_get (caf_decl
);
1857 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1861 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1865 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1868 /* The following code assumes that the coarray is a component reachable via
1869 only scalar components/variables; the Fortran standard guarantees this. */
1871 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1872 if (ref
->type
== REF_COMPONENT
)
1874 gfc_component
*comp
= ref
->u
.c
.component
;
1876 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1877 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1878 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1879 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1880 comp
->backend_decl
, NULL_TREE
);
1881 if (comp
->ts
.type
== BT_CLASS
)
1883 caf_decl
= gfc_class_data_get (caf_decl
);
1884 if (CLASS_DATA (comp
)->attr
.codimension
)
1890 if (comp
->attr
.codimension
)
1896 gcc_assert (found
&& caf_decl
);
1901 /* Obtain the Coarray token - and optionally also the offset. */
1904 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1905 tree se_expr
, gfc_expr
*expr
)
1909 /* Coarray token. */
1910 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1912 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1913 == GFC_ARRAY_ALLOCATABLE
1914 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1915 *token
= gfc_conv_descriptor_token (caf_decl
);
1917 else if (DECL_LANG_SPECIFIC (caf_decl
)
1918 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1919 *token
= GFC_DECL_TOKEN (caf_decl
);
1922 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1923 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1924 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1930 /* Offset between the coarray base address and the address wanted. */
1931 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1932 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1933 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1934 *offset
= build_int_cst (gfc_array_index_type
, 0);
1935 else if (DECL_LANG_SPECIFIC (caf_decl
)
1936 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1937 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1938 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1939 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1941 *offset
= build_int_cst (gfc_array_index_type
, 0);
1943 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1944 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1946 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1947 tmp
= gfc_conv_descriptor_data_get (tmp
);
1949 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1950 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1953 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1957 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1958 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1960 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1961 && expr
->symtree
->n
.sym
->attr
.codimension
1962 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
1964 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
1965 gfc_ref
*ref
= base_expr
->ref
;
1968 // Iterate through the refs until the last one.
1972 if (ref
->type
== REF_ARRAY
1973 && ref
->u
.ar
.type
!= AR_FULL
)
1975 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
1977 for (i
= 0; i
< ranksum
; ++i
)
1979 ref
->u
.ar
.start
[i
] = NULL
;
1980 ref
->u
.ar
.end
[i
] = NULL
;
1982 ref
->u
.ar
.type
= AR_FULL
;
1984 gfc_init_se (&base_se
, NULL
);
1985 if (gfc_caf_attr (base_expr
).dimension
)
1987 gfc_conv_expr_descriptor (&base_se
, base_expr
);
1988 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
1992 gfc_conv_expr (&base_se
, base_expr
);
1996 gfc_free_expr (base_expr
);
1997 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
1998 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2000 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2001 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2004 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2008 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2009 fold_convert (gfc_array_index_type
, *offset
),
2010 fold_convert (gfc_array_index_type
, tmp
));
2014 /* Convert the coindex of a coarray into an image index; the result is
2015 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2016 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2019 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2022 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2026 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2027 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2029 gcc_assert (ref
!= NULL
);
2031 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2033 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2037 img_idx
= integer_zero_node
;
2038 extent
= integer_one_node
;
2039 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2040 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2042 gfc_init_se (&se
, NULL
);
2043 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2044 gfc_add_block_to_block (block
, &se
.pre
);
2045 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2046 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2047 integer_type_node
, se
.expr
,
2048 fold_convert(integer_type_node
, lbound
));
2049 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2051 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2053 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2055 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2056 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2057 tmp
= fold_convert (integer_type_node
, tmp
);
2058 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2059 integer_type_node
, extent
, tmp
);
2063 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2065 gfc_init_se (&se
, NULL
);
2066 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2067 gfc_add_block_to_block (block
, &se
.pre
);
2068 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2069 lbound
= fold_convert (integer_type_node
, lbound
);
2070 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2071 integer_type_node
, se
.expr
, lbound
);
2072 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2074 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2076 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2078 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2079 ubound
= fold_convert (integer_type_node
, ubound
);
2080 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2081 integer_type_node
, ubound
, lbound
);
2082 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2083 tmp
, integer_one_node
);
2084 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2085 integer_type_node
, extent
, tmp
);
2088 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2089 img_idx
, integer_one_node
);
2094 /* For each character array constructor subexpression without a ts.u.cl->length,
2095 replace it by its first element (if there aren't any elements, the length
2096 should already be set to zero). */
2099 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2101 gfc_actual_arglist
* arg
;
2107 switch (e
->expr_type
)
2111 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2112 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2116 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2120 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2121 flatten_array_ctors_without_strlen (arg
->expr
);
2126 /* We've found what we're looking for. */
2127 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2132 gcc_assert (e
->value
.constructor
);
2134 c
= gfc_constructor_first (e
->value
.constructor
);
2138 flatten_array_ctors_without_strlen (new_expr
);
2139 gfc_replace_expr (e
, new_expr
);
2143 /* Otherwise, fall through to handle constructor elements. */
2145 case EXPR_STRUCTURE
:
2146 for (c
= gfc_constructor_first (e
->value
.constructor
);
2147 c
; c
= gfc_constructor_next (c
))
2148 flatten_array_ctors_without_strlen (c
->expr
);
2158 /* Generate code to initialize a string length variable. Returns the
2159 value. For array constructors, cl->length might be NULL and in this case,
2160 the first element of the constructor is needed. expr is the original
2161 expression so we can access it but can be NULL if this is not needed. */
2164 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2168 gfc_init_se (&se
, NULL
);
2170 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2173 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2174 "flatten" array constructors by taking their first element; all elements
2175 should be the same length or a cl->length should be present. */
2178 gfc_expr
* expr_flat
;
2180 expr_flat
= gfc_copy_expr (expr
);
2181 flatten_array_ctors_without_strlen (expr_flat
);
2182 gfc_resolve_expr (expr_flat
);
2184 gfc_conv_expr (&se
, expr_flat
);
2185 gfc_add_block_to_block (pblock
, &se
.pre
);
2186 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2188 gfc_free_expr (expr_flat
);
2192 /* Convert cl->length. */
2194 gcc_assert (cl
->length
);
2196 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2197 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2198 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2199 gfc_add_block_to_block (pblock
, &se
.pre
);
2201 if (cl
->backend_decl
)
2202 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2204 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2209 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2210 const char *name
, locus
*where
)
2220 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2221 type
= build_pointer_type (type
);
2223 gfc_init_se (&start
, se
);
2224 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2225 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2227 if (integer_onep (start
.expr
))
2228 gfc_conv_string_parameter (se
);
2233 /* Avoid multiple evaluation of substring start. */
2234 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2235 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2237 /* Change the start of the string. */
2238 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2241 tmp
= build_fold_indirect_ref_loc (input_location
,
2243 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2244 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2247 /* Length = end + 1 - start. */
2248 gfc_init_se (&end
, se
);
2249 if (ref
->u
.ss
.end
== NULL
)
2250 end
.expr
= se
->string_length
;
2253 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2254 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2258 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2259 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2261 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2263 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2264 boolean_type_node
, start
.expr
,
2267 /* Check lower bound. */
2268 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2270 build_int_cst (gfc_charlen_type_node
, 1));
2271 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2272 boolean_type_node
, nonempty
, fault
);
2274 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2275 "is less than one", name
);
2277 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2278 "is less than one");
2279 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2280 fold_convert (long_integer_type_node
,
2284 /* Check upper bound. */
2285 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2286 end
.expr
, se
->string_length
);
2287 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2288 boolean_type_node
, nonempty
, fault
);
2290 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2291 "exceeds string length (%%ld)", name
);
2293 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2294 "exceeds string length (%%ld)");
2295 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2296 fold_convert (long_integer_type_node
, end
.expr
),
2297 fold_convert (long_integer_type_node
,
2298 se
->string_length
));
2302 /* Try to calculate the length from the start and end expressions. */
2304 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2308 i_len
= mpz_get_si (length
) + 1;
2312 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2313 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2317 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2318 end
.expr
, start
.expr
);
2319 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2320 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2321 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2322 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2325 se
->string_length
= tmp
;
2329 /* Convert a derived type component reference. */
2332 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2340 c
= ref
->u
.c
.component
;
2342 if (c
->backend_decl
== NULL_TREE
2343 && ref
->u
.c
.sym
!= NULL
)
2344 gfc_get_derived_type (ref
->u
.c
.sym
);
2346 field
= c
->backend_decl
;
2347 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2349 context
= DECL_FIELD_CONTEXT (field
);
2351 /* Components can correspond to fields of different containing
2352 types, as components are created without context, whereas
2353 a concrete use of a component has the type of decl as context.
2354 So, if the type doesn't match, we search the corresponding
2355 FIELD_DECL in the parent type. To not waste too much time
2356 we cache this result in norestrict_decl.
2357 On the other hand, if the context is a UNION or a MAP (a
2358 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2360 if (context
!= TREE_TYPE (decl
)
2361 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2362 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2364 tree f2
= c
->norestrict_decl
;
2365 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2366 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2367 if (TREE_CODE (f2
) == FIELD_DECL
2368 && DECL_NAME (f2
) == DECL_NAME (field
))
2371 c
->norestrict_decl
= f2
;
2375 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2376 && strcmp ("_data", c
->name
) == 0)
2378 /* Found a ref to the _data component. Store the associated ref to
2379 the vptr in se->class_vptr. */
2380 se
->class_vptr
= gfc_class_vptr_get (decl
);
2383 se
->class_vptr
= NULL_TREE
;
2385 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2386 decl
, field
, NULL_TREE
);
2390 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2391 strlen () conditional below. */
2392 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2393 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2395 tmp
= c
->ts
.u
.cl
->backend_decl
;
2396 /* Components must always be constant length. */
2397 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2398 se
->string_length
= tmp
;
2401 if (gfc_deferred_strlen (c
, &field
))
2403 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2405 decl
, field
, NULL_TREE
);
2406 se
->string_length
= tmp
;
2409 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2410 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2411 && c
->ts
.type
!= BT_CHARACTER
)
2412 || c
->attr
.proc_pointer
)
2413 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2418 /* This function deals with component references to components of the
2419 parent type for derived type extensions. */
2421 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2429 c
= ref
->u
.c
.component
;
2431 /* Return if the component is in the parent type. */
2432 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2433 if (strcmp (c
->name
, cmp
->name
) == 0)
2436 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2437 parent
.type
= REF_COMPONENT
;
2439 parent
.u
.c
.sym
= dt
;
2440 parent
.u
.c
.component
= dt
->components
;
2442 if (dt
->backend_decl
== NULL
)
2443 gfc_get_derived_type (dt
);
2445 /* Build the reference and call self. */
2446 gfc_conv_component_ref (se
, &parent
);
2447 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2448 parent
.u
.c
.component
= c
;
2449 conv_parent_component_references (se
, &parent
);
2452 /* Return the contents of a variable. Also handles reference/pointer
2453 variables (all Fortran pointer references are implicit). */
2456 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2461 tree parent_decl
= NULL_TREE
;
2464 bool alternate_entry
;
2467 bool first_time
= true;
2469 sym
= expr
->symtree
->n
.sym
;
2470 is_classarray
= IS_CLASS_ARRAY (sym
);
2474 gfc_ss_info
*ss_info
= ss
->info
;
2476 /* Check that something hasn't gone horribly wrong. */
2477 gcc_assert (ss
!= gfc_ss_terminator
);
2478 gcc_assert (ss_info
->expr
== expr
);
2480 /* A scalarized term. We already know the descriptor. */
2481 se
->expr
= ss_info
->data
.array
.descriptor
;
2482 se
->string_length
= ss_info
->string_length
;
2483 ref
= ss_info
->data
.array
.ref
;
2485 gcc_assert (ref
->type
== REF_ARRAY
2486 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2488 gfc_conv_tmp_array_ref (se
);
2492 tree se_expr
= NULL_TREE
;
2494 se
->expr
= gfc_get_symbol_decl (sym
);
2496 /* Deal with references to a parent results or entries by storing
2497 the current_function_decl and moving to the parent_decl. */
2498 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2499 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2500 && sym
->result
== sym
;
2501 entry_master
= sym
->attr
.result
2502 && sym
->ns
->proc_name
->attr
.entry_master
2503 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2504 if (current_function_decl
)
2505 parent_decl
= DECL_CONTEXT (current_function_decl
);
2507 if ((se
->expr
== parent_decl
&& return_value
)
2508 || (sym
->ns
&& sym
->ns
->proc_name
2510 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2511 && (alternate_entry
|| entry_master
)))
2516 /* Special case for assigning the return value of a function.
2517 Self recursive functions must have an explicit return value. */
2518 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2519 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2521 /* Similarly for alternate entry points. */
2522 else if (alternate_entry
2523 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2526 gfc_entry_list
*el
= NULL
;
2528 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2531 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2536 else if (entry_master
2537 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2539 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2544 /* Procedure actual arguments. */
2545 else if (sym
->attr
.flavor
== FL_PROCEDURE
2546 && se
->expr
!= current_function_decl
)
2548 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2550 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2551 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2557 /* Dereference the expression, where needed. Since characters
2558 are entirely different from other types, they are treated
2560 if (sym
->ts
.type
== BT_CHARACTER
)
2562 /* Dereference character pointer dummy arguments
2564 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2566 || sym
->attr
.function
2567 || sym
->attr
.result
))
2568 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2572 else if (!sym
->attr
.value
)
2574 /* Dereference temporaries for class array dummy arguments. */
2575 if (sym
->attr
.dummy
&& is_classarray
2576 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2578 if (!se
->descriptor_only
)
2579 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2581 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2585 /* Dereference non-character scalar dummy arguments. */
2586 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2587 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2588 && (sym
->ts
.type
!= BT_CLASS
2589 || (!CLASS_DATA (sym
)->attr
.dimension
2590 && !(CLASS_DATA (sym
)->attr
.codimension
2591 && CLASS_DATA (sym
)->attr
.allocatable
))))
2592 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2595 /* Dereference scalar hidden result. */
2596 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2597 && (sym
->attr
.function
|| sym
->attr
.result
)
2598 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2599 && !sym
->attr
.always_explicit
)
2600 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2603 /* Dereference non-character, non-class pointer variables.
2604 These must be dummies, results, or scalars. */
2606 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2607 || gfc_is_associate_pointer (sym
)
2608 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2610 || sym
->attr
.function
2612 || (!sym
->attr
.dimension
2613 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2614 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2616 /* Now treat the class array pointer variables accordingly. */
2617 else if (sym
->ts
.type
== BT_CLASS
2619 && (CLASS_DATA (sym
)->attr
.dimension
2620 || CLASS_DATA (sym
)->attr
.codimension
)
2621 && ((CLASS_DATA (sym
)->as
2622 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2623 || CLASS_DATA (sym
)->attr
.allocatable
2624 || CLASS_DATA (sym
)->attr
.class_pointer
))
2625 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2627 /* And the case where a non-dummy, non-result, non-function,
2628 non-allotable and non-pointer classarray is present. This case was
2629 previously covered by the first if, but with introducing the
2630 condition !is_classarray there, that case has to be covered
2632 else if (sym
->ts
.type
== BT_CLASS
2634 && !sym
->attr
.function
2635 && !sym
->attr
.result
2636 && (CLASS_DATA (sym
)->attr
.dimension
2637 || CLASS_DATA (sym
)->attr
.codimension
)
2639 || !CLASS_DATA (sym
)->attr
.allocatable
)
2640 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2641 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2648 /* For character variables, also get the length. */
2649 if (sym
->ts
.type
== BT_CHARACTER
)
2651 /* If the character length of an entry isn't set, get the length from
2652 the master function instead. */
2653 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2654 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2656 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2657 gcc_assert (se
->string_length
);
2665 /* Return the descriptor if that's what we want and this is an array
2666 section reference. */
2667 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2669 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2670 /* Return the descriptor for array pointers and allocations. */
2671 if (se
->want_pointer
2672 && ref
->next
== NULL
&& (se
->descriptor_only
))
2675 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2676 /* Return a pointer to an element. */
2680 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2681 && se
->descriptor_only
2682 && !CLASS_DATA (sym
)->attr
.allocatable
2683 && !CLASS_DATA (sym
)->attr
.class_pointer
2684 && CLASS_DATA (sym
)->as
2685 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2686 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2687 /* Skip the first ref of a _data component, because for class
2688 arrays that one is already done by introducing a temporary
2689 array descriptor. */
2692 if (ref
->u
.c
.sym
->attr
.extension
)
2693 conv_parent_component_references (se
, ref
);
2695 gfc_conv_component_ref (se
, ref
);
2696 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2697 && se
->want_pointer
&& se
->descriptor_only
)
2703 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2704 expr
->symtree
->name
, &expr
->where
);
2714 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2716 if (se
->want_pointer
)
2718 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2719 gfc_conv_string_parameter (se
);
2721 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2726 /* Unary ops are easy... Or they would be if ! was a valid op. */
2729 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2734 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2735 /* Initialize the operand. */
2736 gfc_init_se (&operand
, se
);
2737 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2738 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2740 type
= gfc_typenode_for_spec (&expr
->ts
);
2742 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2743 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2744 All other unary operators have an equivalent GIMPLE unary operator. */
2745 if (code
== TRUTH_NOT_EXPR
)
2746 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2747 build_int_cst (type
, 0));
2749 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2753 /* Expand power operator to optimal multiplications when a value is raised
2754 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2755 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2756 Programming", 3rd Edition, 1998. */
2758 /* This code is mostly duplicated from expand_powi in the backend.
2759 We establish the "optimal power tree" lookup table with the defined size.
2760 The items in the table are the exponents used to calculate the index
2761 exponents. Any integer n less than the value can get an "addition chain",
2762 with the first node being one. */
2763 #define POWI_TABLE_SIZE 256
2765 /* The table is from builtins.c. */
2766 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2768 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2769 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2770 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2771 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2772 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2773 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2774 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2775 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2776 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2777 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2778 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2779 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2780 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2781 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2782 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2783 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2784 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2785 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2786 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2787 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2788 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2789 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2790 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2791 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2792 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2793 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2794 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2795 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2796 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2797 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2798 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2799 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2802 /* If n is larger than lookup table's max index, we use the "window
2804 #define POWI_WINDOW_SIZE 3
2806 /* Recursive function to expand the power operator. The temporary
2807 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2809 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2816 if (n
< POWI_TABLE_SIZE
)
2821 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2822 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2826 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2827 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2828 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2832 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2836 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2837 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2839 if (n
< POWI_TABLE_SIZE
)
2846 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2847 return 1. Else return 0 and a call to runtime library functions
2848 will have to be built. */
2850 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2855 tree vartmp
[POWI_TABLE_SIZE
];
2857 unsigned HOST_WIDE_INT n
;
2859 wide_int wrhs
= rhs
;
2861 /* If exponent is too large, we won't expand it anyway, so don't bother
2862 with large integer values. */
2863 if (!wi::fits_shwi_p (wrhs
))
2866 m
= wrhs
.to_shwi ();
2867 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2868 of the asymmetric range of the integer type. */
2869 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2871 type
= TREE_TYPE (lhs
);
2872 sgn
= tree_int_cst_sgn (rhs
);
2874 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2875 || optimize_size
) && (m
> 2 || m
< -1))
2881 se
->expr
= gfc_build_const (type
, integer_one_node
);
2885 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2886 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2888 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2889 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2890 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2891 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2894 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2897 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2898 boolean_type_node
, tmp
, cond
);
2899 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2900 tmp
, build_int_cst (type
, 1),
2901 build_int_cst (type
, 0));
2905 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2906 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2907 build_int_cst (type
, -1),
2908 build_int_cst (type
, 0));
2909 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2910 cond
, build_int_cst (type
, 1), tmp
);
2914 memset (vartmp
, 0, sizeof (vartmp
));
2918 tmp
= gfc_build_const (type
, integer_one_node
);
2919 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2923 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2929 /* Power op (**). Constant integer exponent has special handling. */
2932 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2934 tree gfc_int4_type_node
;
2937 int res_ikind_1
, res_ikind_2
;
2942 gfc_init_se (&lse
, se
);
2943 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2944 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2945 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2947 gfc_init_se (&rse
, se
);
2948 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2949 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2951 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2952 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2953 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2956 gfc_int4_type_node
= gfc_get_int_type (4);
2958 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2959 library routine. But in the end, we have to convert the result back
2960 if this case applies -- with res_ikind_K, we keep track whether operand K
2961 falls into this case. */
2965 kind
= expr
->value
.op
.op1
->ts
.kind
;
2966 switch (expr
->value
.op
.op2
->ts
.type
)
2969 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2974 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2975 res_ikind_2
= ikind
;
2997 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2999 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3026 switch (expr
->value
.op
.op1
->ts
.type
)
3029 if (kind
== 3) /* Case 16 was not handled properly above. */
3031 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3035 /* Use builtins for real ** int4. */
3041 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3045 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3049 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3053 /* Use the __builtin_powil() only if real(kind=16) is
3054 actually the C long double type. */
3055 if (!gfc_real16_is_float128
)
3056 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3064 /* If we don't have a good builtin for this, go for the
3065 library function. */
3067 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3071 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3080 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3084 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3092 se
->expr
= build_call_expr_loc (input_location
,
3093 fndecl
, 2, lse
.expr
, rse
.expr
);
3095 /* Convert the result back if it is of wrong integer kind. */
3096 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3098 /* We want the maximum of both operand kinds as result. */
3099 if (res_ikind_1
< res_ikind_2
)
3100 res_ikind_1
= res_ikind_2
;
3101 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3106 /* Generate code to allocate a string temporary. */
3109 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3114 if (gfc_can_put_var_on_stack (len
))
3116 /* Create a temporary variable to hold the result. */
3117 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3118 gfc_charlen_type_node
, len
,
3119 build_int_cst (gfc_charlen_type_node
, 1));
3120 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3122 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3123 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3125 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3127 var
= gfc_create_var (tmp
, "str");
3128 var
= gfc_build_addr_expr (type
, var
);
3132 /* Allocate a temporary to hold the result. */
3133 var
= gfc_create_var (type
, "pstr");
3134 gcc_assert (POINTER_TYPE_P (type
));
3135 tmp
= TREE_TYPE (type
);
3136 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3137 tmp
= TREE_TYPE (tmp
);
3138 tmp
= TYPE_SIZE_UNIT (tmp
);
3139 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3140 fold_convert (size_type_node
, len
),
3141 fold_convert (size_type_node
, tmp
));
3142 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3143 gfc_add_modify (&se
->pre
, var
, tmp
);
3145 /* Free the temporary afterwards. */
3146 tmp
= gfc_call_free (var
);
3147 gfc_add_expr_to_block (&se
->post
, tmp
);
3154 /* Handle a string concatenation operation. A temporary will be allocated to
3158 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3161 tree len
, type
, var
, tmp
, fndecl
;
3163 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3164 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3165 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3167 gfc_init_se (&lse
, se
);
3168 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3169 gfc_conv_string_parameter (&lse
);
3170 gfc_init_se (&rse
, se
);
3171 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3172 gfc_conv_string_parameter (&rse
);
3174 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3175 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3177 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3178 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3179 if (len
== NULL_TREE
)
3181 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3182 TREE_TYPE (lse
.string_length
),
3183 lse
.string_length
, rse
.string_length
);
3186 type
= build_pointer_type (type
);
3188 var
= gfc_conv_string_tmp (se
, type
, len
);
3190 /* Do the actual concatenation. */
3191 if (expr
->ts
.kind
== 1)
3192 fndecl
= gfor_fndecl_concat_string
;
3193 else if (expr
->ts
.kind
== 4)
3194 fndecl
= gfor_fndecl_concat_string_char4
;
3198 tmp
= build_call_expr_loc (input_location
,
3199 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3200 rse
.string_length
, rse
.expr
);
3201 gfc_add_expr_to_block (&se
->pre
, tmp
);
3203 /* Add the cleanup for the operands. */
3204 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3205 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3208 se
->string_length
= len
;
3211 /* Translates an op expression. Common (binary) cases are handled by this
3212 function, others are passed on. Recursion is used in either case.
3213 We use the fact that (op1.ts == op2.ts) (except for the power
3215 Operators need no special handling for scalarized expressions as long as
3216 they call gfc_conv_simple_val to get their operands.
3217 Character strings get special handling. */
3220 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3222 enum tree_code code
;
3231 switch (expr
->value
.op
.op
)
3233 case INTRINSIC_PARENTHESES
:
3234 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3235 && flag_protect_parens
)
3237 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3238 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3243 case INTRINSIC_UPLUS
:
3244 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3247 case INTRINSIC_UMINUS
:
3248 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3252 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3255 case INTRINSIC_PLUS
:
3259 case INTRINSIC_MINUS
:
3263 case INTRINSIC_TIMES
:
3267 case INTRINSIC_DIVIDE
:
3268 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3269 an integer, we must round towards zero, so we use a
3271 if (expr
->ts
.type
== BT_INTEGER
)
3272 code
= TRUNC_DIV_EXPR
;
3277 case INTRINSIC_POWER
:
3278 gfc_conv_power_op (se
, expr
);
3281 case INTRINSIC_CONCAT
:
3282 gfc_conv_concat_op (se
, expr
);
3286 code
= TRUTH_ANDIF_EXPR
;
3291 code
= TRUTH_ORIF_EXPR
;
3295 /* EQV and NEQV only work on logicals, but since we represent them
3296 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3298 case INTRINSIC_EQ_OS
:
3306 case INTRINSIC_NE_OS
:
3307 case INTRINSIC_NEQV
:
3314 case INTRINSIC_GT_OS
:
3321 case INTRINSIC_GE_OS
:
3328 case INTRINSIC_LT_OS
:
3335 case INTRINSIC_LE_OS
:
3341 case INTRINSIC_USER
:
3342 case INTRINSIC_ASSIGN
:
3343 /* These should be converted into function calls by the frontend. */
3347 fatal_error (input_location
, "Unknown intrinsic op");
3351 /* The only exception to this is **, which is handled separately anyway. */
3352 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3354 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3358 gfc_init_se (&lse
, se
);
3359 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3360 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3363 gfc_init_se (&rse
, se
);
3364 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3365 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3369 gfc_conv_string_parameter (&lse
);
3370 gfc_conv_string_parameter (&rse
);
3372 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3373 rse
.string_length
, rse
.expr
,
3374 expr
->value
.op
.op1
->ts
.kind
,
3376 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3377 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3380 type
= gfc_typenode_for_spec (&expr
->ts
);
3384 /* The result of logical ops is always boolean_type_node. */
3385 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3386 lse
.expr
, rse
.expr
);
3387 se
->expr
= convert (type
, tmp
);
3390 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3392 /* Add the post blocks. */
3393 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3394 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3397 /* If a string's length is one, we convert it to a single character. */
3400 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3404 || !tree_fits_uhwi_p (len
)
3405 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3408 if (TREE_INT_CST_LOW (len
) == 1)
3410 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3411 return build_fold_indirect_ref_loc (input_location
, str
);
3415 && TREE_CODE (str
) == ADDR_EXPR
3416 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3417 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3418 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3419 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3420 && TREE_INT_CST_LOW (len
) > 1
3421 && TREE_INT_CST_LOW (len
)
3422 == (unsigned HOST_WIDE_INT
)
3423 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3425 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3426 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3427 if (TREE_CODE (ret
) == INTEGER_CST
)
3429 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3430 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3431 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3433 for (i
= 1; i
< length
; i
++)
3446 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3449 if (sym
->backend_decl
)
3451 /* This becomes the nominal_type in
3452 function.c:assign_parm_find_data_types. */
3453 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3454 /* This becomes the passed_type in
3455 function.c:assign_parm_find_data_types. C promotes char to
3456 integer for argument passing. */
3457 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3459 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3464 /* If we have a constant character expression, make it into an
3466 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3471 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3472 (int)(*expr
)->value
.character
.string
[0]);
3473 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3475 /* The expr needs to be compatible with a C int. If the
3476 conversion fails, then the 2 causes an ICE. */
3477 ts
.type
= BT_INTEGER
;
3478 ts
.kind
= gfc_c_int_kind
;
3479 gfc_convert_type (*expr
, &ts
, 2);
3482 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3484 if ((*expr
)->ref
== NULL
)
3486 se
->expr
= gfc_string_to_single_character
3487 (build_int_cst (integer_type_node
, 1),
3488 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3490 ((*expr
)->symtree
->n
.sym
)),
3495 gfc_conv_variable (se
, *expr
);
3496 se
->expr
= gfc_string_to_single_character
3497 (build_int_cst (integer_type_node
, 1),
3498 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3506 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3507 if STR is a string literal, otherwise return -1. */
3510 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3513 && TREE_CODE (str
) == ADDR_EXPR
3514 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3515 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3516 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3517 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3518 && tree_fits_uhwi_p (len
)
3519 && tree_to_uhwi (len
) >= 1
3520 && tree_to_uhwi (len
)
3521 == (unsigned HOST_WIDE_INT
)
3522 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3524 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3525 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3526 if (TREE_CODE (folded
) == INTEGER_CST
)
3528 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3529 int length
= TREE_STRING_LENGTH (string_cst
);
3530 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3532 for (; length
> 0; length
--)
3533 if (ptr
[length
- 1] != ' ')
3542 /* Helper to build a call to memcmp. */
3545 build_memcmp_call (tree s1
, tree s2
, tree n
)
3549 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3550 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3552 s1
= fold_convert (pvoid_type_node
, s1
);
3554 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3555 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3557 s2
= fold_convert (pvoid_type_node
, s2
);
3559 n
= fold_convert (size_type_node
, n
);
3561 tmp
= build_call_expr_loc (input_location
,
3562 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3565 return fold_convert (integer_type_node
, tmp
);
3568 /* Compare two strings. If they are all single characters, the result is the
3569 subtraction of them. Otherwise, we build a library call. */
3572 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3573 enum tree_code code
)
3579 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3580 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3582 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3583 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3585 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3587 /* Deal with single character specially. */
3588 sc1
= fold_convert (integer_type_node
, sc1
);
3589 sc2
= fold_convert (integer_type_node
, sc2
);
3590 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3594 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3596 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3598 /* If one string is a string literal with LEN_TRIM longer
3599 than the length of the second string, the strings
3601 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3602 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3603 return integer_one_node
;
3604 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3605 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3606 return integer_one_node
;
3609 /* We can compare via memcpy if the strings are known to be equal
3610 in length and they are
3612 - kind=4 and the comparison is for (in)equality. */
3614 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3615 && tree_int_cst_equal (len1
, len2
)
3616 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3621 chartype
= gfc_get_char_type (kind
);
3622 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3623 fold_convert (TREE_TYPE(len1
),
3624 TYPE_SIZE_UNIT(chartype
)),
3626 return build_memcmp_call (str1
, str2
, tmp
);
3629 /* Build a call for the comparison. */
3631 fndecl
= gfor_fndecl_compare_string
;
3633 fndecl
= gfor_fndecl_compare_string_char4
;
3637 return build_call_expr_loc (input_location
, fndecl
, 4,
3638 len1
, str1
, len2
, str2
);
3642 /* Return the backend_decl for a procedure pointer component. */
3645 get_proc_ptr_comp (gfc_expr
*e
)
3651 gfc_init_se (&comp_se
, NULL
);
3652 e2
= gfc_copy_expr (e
);
3653 /* We have to restore the expr type later so that gfc_free_expr frees
3654 the exact same thing that was allocated.
3655 TODO: This is ugly. */
3656 old_type
= e2
->expr_type
;
3657 e2
->expr_type
= EXPR_VARIABLE
;
3658 gfc_conv_expr (&comp_se
, e2
);
3659 e2
->expr_type
= old_type
;
3661 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3665 /* Convert a typebound function reference from a class object. */
3667 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3672 if (!VAR_P (base_object
))
3674 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3675 gfc_add_modify (&se
->pre
, var
, base_object
);
3677 se
->expr
= gfc_class_vptr_get (base_object
);
3678 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3680 while (ref
&& ref
->next
)
3682 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3683 if (ref
->u
.c
.sym
->attr
.extension
)
3684 conv_parent_component_references (se
, ref
);
3685 gfc_conv_component_ref (se
, ref
);
3686 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3691 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3695 if (gfc_is_proc_ptr_comp (expr
))
3696 tmp
= get_proc_ptr_comp (expr
);
3697 else if (sym
->attr
.dummy
)
3699 tmp
= gfc_get_symbol_decl (sym
);
3700 if (sym
->attr
.proc_pointer
)
3701 tmp
= build_fold_indirect_ref_loc (input_location
,
3703 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3704 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3708 if (!sym
->backend_decl
)
3709 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3711 TREE_USED (sym
->backend_decl
) = 1;
3713 tmp
= sym
->backend_decl
;
3715 if (sym
->attr
.cray_pointee
)
3717 /* TODO - make the cray pointee a pointer to a procedure,
3718 assign the pointer to it and use it for the call. This
3720 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3721 gfc_get_symbol_decl (sym
->cp_pointer
));
3722 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3725 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3727 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3728 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3735 /* Initialize MAPPING. */
3738 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3740 mapping
->syms
= NULL
;
3741 mapping
->charlens
= NULL
;
3745 /* Free all memory held by MAPPING (but not MAPPING itself). */
3748 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3750 gfc_interface_sym_mapping
*sym
;
3751 gfc_interface_sym_mapping
*nextsym
;
3753 gfc_charlen
*nextcl
;
3755 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3757 nextsym
= sym
->next
;
3758 sym
->new_sym
->n
.sym
->formal
= NULL
;
3759 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3760 gfc_free_expr (sym
->expr
);
3761 free (sym
->new_sym
);
3764 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3767 gfc_free_expr (cl
->length
);
3773 /* Return a copy of gfc_charlen CL. Add the returned structure to
3774 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3776 static gfc_charlen
*
3777 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3780 gfc_charlen
*new_charlen
;
3782 new_charlen
= gfc_get_charlen ();
3783 new_charlen
->next
= mapping
->charlens
;
3784 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3786 mapping
->charlens
= new_charlen
;
3791 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3792 array variable that can be used as the actual argument for dummy
3793 argument SYM. Add any initialization code to BLOCK. PACKED is as
3794 for gfc_get_nodesc_array_type and DATA points to the first element
3795 in the passed array. */
3798 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3799 gfc_packed packed
, tree data
)
3804 type
= gfc_typenode_for_spec (&sym
->ts
);
3805 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3806 !sym
->attr
.target
&& !sym
->attr
.pointer
3807 && !sym
->attr
.proc_pointer
);
3809 var
= gfc_create_var (type
, "ifm");
3810 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3816 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3817 and offset of descriptorless array type TYPE given that it has the same
3818 size as DESC. Add any set-up code to BLOCK. */
3821 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3828 offset
= gfc_index_zero_node
;
3829 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3831 dim
= gfc_rank_cst
[n
];
3832 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3833 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3835 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3836 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3837 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3838 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3840 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3842 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3843 gfc_array_index_type
,
3844 gfc_conv_descriptor_ubound_get (desc
, dim
),
3845 gfc_conv_descriptor_lbound_get (desc
, dim
));
3846 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3847 gfc_array_index_type
,
3848 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3849 tmp
= gfc_evaluate_now (tmp
, block
);
3850 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3852 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3853 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3854 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3855 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3856 gfc_array_index_type
, offset
, tmp
);
3858 offset
= gfc_evaluate_now (offset
, block
);
3859 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3863 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3864 in SE. The caller may still use se->expr and se->string_length after
3865 calling this function. */
3868 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3869 gfc_symbol
* sym
, gfc_se
* se
,
3872 gfc_interface_sym_mapping
*sm
;
3876 gfc_symbol
*new_sym
;
3878 gfc_symtree
*new_symtree
;
3880 /* Create a new symbol to represent the actual argument. */
3881 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3882 new_sym
->ts
= sym
->ts
;
3883 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3884 new_sym
->attr
.referenced
= 1;
3885 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3886 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3887 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3888 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3889 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3890 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3891 new_sym
->attr
.function
= sym
->attr
.function
;
3893 /* Ensure that the interface is available and that
3894 descriptors are passed for array actual arguments. */
3895 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3897 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3898 new_sym
->attr
.always_explicit
3899 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3902 /* Create a fake symtree for it. */
3904 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3905 new_symtree
->n
.sym
= new_sym
;
3906 gcc_assert (new_symtree
== root
);
3908 /* Create a dummy->actual mapping. */
3909 sm
= XCNEW (gfc_interface_sym_mapping
);
3910 sm
->next
= mapping
->syms
;
3912 sm
->new_sym
= new_symtree
;
3913 sm
->expr
= gfc_copy_expr (expr
);
3916 /* Stabilize the argument's value. */
3917 if (!sym
->attr
.function
&& se
)
3918 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3920 if (sym
->ts
.type
== BT_CHARACTER
)
3922 /* Create a copy of the dummy argument's length. */
3923 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3924 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3926 /* If the length is specified as "*", record the length that
3927 the caller is passing. We should use the callee's length
3928 in all other cases. */
3929 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3931 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3932 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3939 /* Use the passed value as-is if the argument is a function. */
3940 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3943 /* If the argument is a pass-by-value scalar, use the value as is. */
3944 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3947 /* If the argument is either a string or a pointer to a string,
3948 convert it to a boundless character type. */
3949 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3951 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3952 tmp
= build_pointer_type (tmp
);
3953 if (sym
->attr
.pointer
)
3954 value
= build_fold_indirect_ref_loc (input_location
,
3958 value
= fold_convert (tmp
, value
);
3961 /* If the argument is a scalar, a pointer to an array or an allocatable,
3963 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3964 value
= build_fold_indirect_ref_loc (input_location
,
3967 /* For character(*), use the actual argument's descriptor. */
3968 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3969 value
= build_fold_indirect_ref_loc (input_location
,
3972 /* If the argument is an array descriptor, use it to determine
3973 information about the actual argument's shape. */
3974 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3975 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3977 /* Get the actual argument's descriptor. */
3978 desc
= build_fold_indirect_ref_loc (input_location
,
3981 /* Create the replacement variable. */
3982 tmp
= gfc_conv_descriptor_data_get (desc
);
3983 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3986 /* Use DESC to work out the upper bounds, strides and offset. */
3987 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3990 /* Otherwise we have a packed array. */
3991 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3992 PACKED_FULL
, se
->expr
);
3994 new_sym
->backend_decl
= value
;
3998 /* Called once all dummy argument mappings have been added to MAPPING,
3999 but before the mapping is used to evaluate expressions. Pre-evaluate
4000 the length of each argument, adding any initialization code to PRE and
4001 any finalization code to POST. */
4004 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4005 stmtblock_t
* pre
, stmtblock_t
* post
)
4007 gfc_interface_sym_mapping
*sym
;
4011 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4012 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4013 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4015 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4016 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4017 gfc_init_se (&se
, NULL
);
4018 gfc_conv_expr (&se
, expr
);
4019 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4020 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4021 gfc_add_block_to_block (pre
, &se
.pre
);
4022 gfc_add_block_to_block (post
, &se
.post
);
4024 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4029 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4033 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4034 gfc_constructor_base base
)
4037 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4039 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4042 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4043 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4044 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4050 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4054 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4059 for (; ref
; ref
= ref
->next
)
4063 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4065 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4066 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4067 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4075 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4076 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4082 /* Convert intrinsic function calls into result expressions. */
4085 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4093 arg1
= expr
->value
.function
.actual
->expr
;
4094 if (expr
->value
.function
.actual
->next
)
4095 arg2
= expr
->value
.function
.actual
->next
->expr
;
4099 sym
= arg1
->symtree
->n
.sym
;
4101 if (sym
->attr
.dummy
)
4106 switch (expr
->value
.function
.isym
->id
)
4109 /* TODO figure out why this condition is necessary. */
4110 if (sym
->attr
.function
4111 && (arg1
->ts
.u
.cl
->length
== NULL
4112 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4113 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4116 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4119 case GFC_ISYM_LEN_TRIM
:
4120 new_expr
= gfc_copy_expr (arg1
);
4121 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4126 gfc_replace_expr (arg1
, new_expr
);
4130 if (!sym
->as
|| sym
->as
->rank
== 0)
4133 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4135 dup
= mpz_get_si (arg2
->value
.integer
);
4140 dup
= sym
->as
->rank
;
4144 for (; d
< dup
; d
++)
4148 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4150 gfc_free_expr (new_expr
);
4154 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4155 gfc_get_int_expr (gfc_default_integer_kind
,
4157 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4159 new_expr
= gfc_multiply (new_expr
, tmp
);
4165 case GFC_ISYM_LBOUND
:
4166 case GFC_ISYM_UBOUND
:
4167 /* TODO These implementations of lbound and ubound do not limit if
4168 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4170 if (!sym
->as
|| sym
->as
->rank
== 0)
4173 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4174 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4176 /* TODO: If the need arises, this could produce an array of
4180 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4182 if (sym
->as
->lower
[d
])
4183 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4187 if (sym
->as
->upper
[d
])
4188 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4196 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4200 gfc_replace_expr (expr
, new_expr
);
4206 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4207 gfc_interface_mapping
* mapping
)
4209 gfc_formal_arglist
*f
;
4210 gfc_actual_arglist
*actual
;
4212 actual
= expr
->value
.function
.actual
;
4213 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4215 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4220 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4223 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4228 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4230 for (d
= 0; d
< as
->rank
; d
++)
4232 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4233 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4236 expr
->value
.function
.esym
->as
= as
;
4239 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4241 expr
->value
.function
.esym
->ts
.u
.cl
->length
4242 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4244 gfc_apply_interface_mapping_to_expr (mapping
,
4245 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4250 /* EXPR is a copy of an expression that appeared in the interface
4251 associated with MAPPING. Walk it recursively looking for references to
4252 dummy arguments that MAPPING maps to actual arguments. Replace each such
4253 reference with a reference to the associated actual argument. */
4256 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4259 gfc_interface_sym_mapping
*sym
;
4260 gfc_actual_arglist
*actual
;
4265 /* Copying an expression does not copy its length, so do that here. */
4266 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4268 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4269 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4272 /* Apply the mapping to any references. */
4273 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4275 /* ...and to the expression's symbol, if it has one. */
4276 /* TODO Find out why the condition on expr->symtree had to be moved into
4277 the loop rather than being outside it, as originally. */
4278 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4279 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4281 if (sym
->new_sym
->n
.sym
->backend_decl
)
4282 expr
->symtree
= sym
->new_sym
;
4284 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4287 /* ...and to subexpressions in expr->value. */
4288 switch (expr
->expr_type
)
4293 case EXPR_SUBSTRING
:
4297 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4298 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4302 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4303 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4305 if (expr
->value
.function
.esym
== NULL
4306 && expr
->value
.function
.isym
!= NULL
4307 && expr
->value
.function
.actual
->expr
->symtree
4308 && gfc_map_intrinsic_function (expr
, mapping
))
4311 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4312 if (sym
->old
== expr
->value
.function
.esym
)
4314 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4315 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4316 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4321 case EXPR_STRUCTURE
:
4322 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4335 /* Evaluate interface expression EXPR using MAPPING. Store the result
4339 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4340 gfc_se
* se
, gfc_expr
* expr
)
4342 expr
= gfc_copy_expr (expr
);
4343 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4344 gfc_conv_expr (se
, expr
);
4345 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4346 gfc_free_expr (expr
);
4350 /* Returns a reference to a temporary array into which a component of
4351 an actual argument derived type array is copied and then returned
4352 after the function call. */
4354 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4355 sym_intent intent
, bool formal_ptr
)
4363 gfc_array_info
*info
;
4373 gfc_init_se (&lse
, NULL
);
4374 gfc_init_se (&rse
, NULL
);
4376 /* Walk the argument expression. */
4377 rss
= gfc_walk_expr (expr
);
4379 gcc_assert (rss
!= gfc_ss_terminator
);
4381 /* Initialize the scalarizer. */
4382 gfc_init_loopinfo (&loop
);
4383 gfc_add_ss_to_loop (&loop
, rss
);
4385 /* Calculate the bounds of the scalarization. */
4386 gfc_conv_ss_startstride (&loop
);
4388 /* Build an ss for the temporary. */
4389 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4390 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4392 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4393 if (GFC_ARRAY_TYPE_P (base_type
)
4394 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4395 base_type
= gfc_get_element_type (base_type
);
4397 if (expr
->ts
.type
== BT_CLASS
)
4398 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4400 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4401 ? expr
->ts
.u
.cl
->backend_decl
4405 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4407 /* Associate the SS with the loop. */
4408 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4410 /* Setup the scalarizing loops. */
4411 gfc_conv_loop_setup (&loop
, &expr
->where
);
4413 /* Pass the temporary descriptor back to the caller. */
4414 info
= &loop
.temp_ss
->info
->data
.array
;
4415 parmse
->expr
= info
->descriptor
;
4417 /* Setup the gfc_se structures. */
4418 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4419 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4422 lse
.ss
= loop
.temp_ss
;
4423 gfc_mark_ss_chain_used (rss
, 1);
4424 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4426 /* Start the scalarized loop body. */
4427 gfc_start_scalarized_body (&loop
, &body
);
4429 /* Translate the expression. */
4430 gfc_conv_expr (&rse
, expr
);
4432 /* Reset the offset for the function call since the loop
4433 is zero based on the data pointer. Note that the temp
4434 comes first in the loop chain since it is added second. */
4435 if (gfc_is_alloc_class_array_function (expr
))
4437 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4438 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4439 gfc_index_zero_node
);
4442 gfc_conv_tmp_array_ref (&lse
);
4444 if (intent
!= INTENT_OUT
)
4446 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4447 gfc_add_expr_to_block (&body
, tmp
);
4448 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4449 gfc_trans_scalarizing_loops (&loop
, &body
);
4453 /* Make sure that the temporary declaration survives by merging
4454 all the loop declarations into the current context. */
4455 for (n
= 0; n
< loop
.dimen
; n
++)
4457 gfc_merge_block_scope (&body
);
4458 body
= loop
.code
[loop
.order
[n
]];
4460 gfc_merge_block_scope (&body
);
4463 /* Add the post block after the second loop, so that any
4464 freeing of allocated memory is done at the right time. */
4465 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4467 /**********Copy the temporary back again.*********/
4469 gfc_init_se (&lse
, NULL
);
4470 gfc_init_se (&rse
, NULL
);
4472 /* Walk the argument expression. */
4473 lss
= gfc_walk_expr (expr
);
4474 rse
.ss
= loop
.temp_ss
;
4477 /* Initialize the scalarizer. */
4478 gfc_init_loopinfo (&loop2
);
4479 gfc_add_ss_to_loop (&loop2
, lss
);
4481 dimen
= rse
.ss
->dimen
;
4483 /* Skip the write-out loop for this case. */
4484 if (gfc_is_alloc_class_array_function (expr
))
4485 goto class_array_fcn
;
4487 /* Calculate the bounds of the scalarization. */
4488 gfc_conv_ss_startstride (&loop2
);
4490 /* Setup the scalarizing loops. */
4491 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4493 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4494 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4496 gfc_mark_ss_chain_used (lss
, 1);
4497 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4499 /* Declare the variable to hold the temporary offset and start the
4500 scalarized loop body. */
4501 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4502 gfc_start_scalarized_body (&loop2
, &body
);
4504 /* Build the offsets for the temporary from the loop variables. The
4505 temporary array has lbounds of zero and strides of one in all
4506 dimensions, so this is very simple. The offset is only computed
4507 outside the innermost loop, so the overall transfer could be
4508 optimized further. */
4509 info
= &rse
.ss
->info
->data
.array
;
4511 tmp_index
= gfc_index_zero_node
;
4512 for (n
= dimen
- 1; n
> 0; n
--)
4515 tmp
= rse
.loop
->loopvar
[n
];
4516 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4517 tmp
, rse
.loop
->from
[n
]);
4518 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4521 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4522 gfc_array_index_type
,
4523 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4524 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4525 gfc_array_index_type
,
4526 tmp_str
, gfc_index_one_node
);
4528 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4529 gfc_array_index_type
, tmp
, tmp_str
);
4532 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4533 gfc_array_index_type
,
4534 tmp_index
, rse
.loop
->from
[0]);
4535 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4537 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4538 gfc_array_index_type
,
4539 rse
.loop
->loopvar
[0], offset
);
4541 /* Now use the offset for the reference. */
4542 tmp
= build_fold_indirect_ref_loc (input_location
,
4544 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4546 if (expr
->ts
.type
== BT_CHARACTER
)
4547 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4549 gfc_conv_expr (&lse
, expr
);
4551 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4553 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4554 gfc_add_expr_to_block (&body
, tmp
);
4556 /* Generate the copying loops. */
4557 gfc_trans_scalarizing_loops (&loop2
, &body
);
4559 /* Wrap the whole thing up by adding the second loop to the post-block
4560 and following it by the post-block of the first loop. In this way,
4561 if the temporary needs freeing, it is done after use! */
4562 if (intent
!= INTENT_IN
)
4564 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4565 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4570 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4572 gfc_cleanup_loop (&loop
);
4573 gfc_cleanup_loop (&loop2
);
4575 /* Pass the string length to the argument expression. */
4576 if (expr
->ts
.type
== BT_CHARACTER
)
4577 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4579 /* Determine the offset for pointer formal arguments and set the
4583 size
= gfc_index_one_node
;
4584 offset
= gfc_index_zero_node
;
4585 for (n
= 0; n
< dimen
; n
++)
4587 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4589 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4590 gfc_array_index_type
, tmp
,
4591 gfc_index_one_node
);
4592 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4596 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4599 gfc_index_one_node
);
4600 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4601 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4602 gfc_array_index_type
,
4604 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4605 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4606 gfc_array_index_type
,
4607 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4608 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4609 gfc_array_index_type
,
4610 tmp
, gfc_index_one_node
);
4611 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4612 gfc_array_index_type
, size
, tmp
);
4615 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4619 /* We want either the address for the data or the address of the descriptor,
4620 depending on the mode of passing array arguments. */
4622 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4624 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4630 /* Generate the code for argument list functions. */
4633 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4635 /* Pass by value for g77 %VAL(arg), pass the address
4636 indirectly for %LOC, else by reference. Thus %REF
4637 is a "do-nothing" and %LOC is the same as an F95
4639 if (strncmp (name
, "%VAL", 4) == 0)
4640 gfc_conv_expr (se
, expr
);
4641 else if (strncmp (name
, "%LOC", 4) == 0)
4643 gfc_conv_expr_reference (se
, expr
);
4644 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4646 else if (strncmp (name
, "%REF", 4) == 0)
4647 gfc_conv_expr_reference (se
, expr
);
4649 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4653 /* This function tells whether the middle-end representation of the expression
4654 E given as input may point to data otherwise accessible through a variable
4656 It is assumed that the only expressions that may alias are variables,
4657 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4659 This function is used to decide whether freeing an expression's allocatable
4660 components is safe or should be avoided.
4662 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4663 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4664 is necessary because for array constructors, aliasing depends on how
4666 - If E is an array constructor used as argument to an elemental procedure,
4667 the array, which is generated through shallow copy by the scalarizer,
4668 is used directly and can alias the expressions it was copied from.
4669 - If E is an array constructor used as argument to a non-elemental
4670 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4671 the array as in the previous case, but then that array is used
4672 to initialize a new descriptor through deep copy. There is no alias
4673 possible in that case.
4674 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4678 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4682 if (e
->expr_type
== EXPR_VARIABLE
)
4684 else if (e
->expr_type
== EXPR_FUNCTION
)
4686 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4688 if (proc_ifc
->result
!= NULL
4689 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4690 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4691 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4692 || proc_ifc
->result
->attr
.pointer
))
4697 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4700 for (c
= gfc_constructor_first (e
->value
.constructor
);
4701 c
; c
= gfc_constructor_next (c
))
4703 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4710 /* Generate code for a procedure call. Note can return se->post != NULL.
4711 If se->direct_byref is set then se->expr contains the return parameter.
4712 Return nonzero, if the call has alternate specifiers.
4713 'expr' is only needed for procedure pointer components. */
4716 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4717 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4718 vec
<tree
, va_gc
> *append_args
)
4720 gfc_interface_mapping mapping
;
4721 vec
<tree
, va_gc
> *arglist
;
4722 vec
<tree
, va_gc
> *retargs
;
4726 gfc_array_info
*info
;
4733 vec
<tree
, va_gc
> *stringargs
;
4734 vec
<tree
, va_gc
> *optionalargs
;
4736 gfc_formal_arglist
*formal
;
4737 gfc_actual_arglist
*arg
;
4738 int has_alternate_specifier
= 0;
4739 bool need_interface_mapping
;
4747 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4748 gfc_component
*comp
= NULL
;
4755 optionalargs
= NULL
;
4760 comp
= gfc_get_proc_ptr_comp (expr
);
4762 bool elemental_proc
= (comp
4763 && comp
->ts
.interface
4764 && comp
->ts
.interface
->attr
.elemental
)
4765 || (comp
&& comp
->attr
.elemental
)
4766 || sym
->attr
.elemental
;
4770 if (!elemental_proc
)
4772 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4773 if (se
->ss
->info
->useflags
)
4775 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4776 && sym
->result
->attr
.dimension
)
4777 || (comp
&& comp
->attr
.dimension
)
4778 || gfc_is_alloc_class_array_function (expr
));
4779 gcc_assert (se
->loop
!= NULL
);
4780 /* Access the previously obtained result. */
4781 gfc_conv_tmp_array_ref (se
);
4785 info
= &se
->ss
->info
->data
.array
;
4790 gfc_init_block (&post
);
4791 gfc_init_interface_mapping (&mapping
);
4794 formal
= gfc_sym_get_dummy_args (sym
);
4795 need_interface_mapping
= sym
->attr
.dimension
||
4796 (sym
->ts
.type
== BT_CHARACTER
4797 && sym
->ts
.u
.cl
->length
4798 && sym
->ts
.u
.cl
->length
->expr_type
4803 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4804 need_interface_mapping
= comp
->attr
.dimension
||
4805 (comp
->ts
.type
== BT_CHARACTER
4806 && comp
->ts
.u
.cl
->length
4807 && comp
->ts
.u
.cl
->length
->expr_type
4811 base_object
= NULL_TREE
;
4812 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4813 is the third and fourth argument to such a function call a value
4814 denoting the number of elements to copy (i.e., most of the time the
4815 length of a deferred length string). */
4816 ulim_copy
= (formal
== NULL
)
4817 && UNLIMITED_POLY (sym
)
4818 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4820 /* Evaluate the arguments. */
4821 for (arg
= args
, argc
= 0; arg
!= NULL
;
4822 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4825 fsym
= formal
? formal
->sym
: NULL
;
4826 parm_kind
= MISSING
;
4828 /* If the procedure requires an explicit interface, the actual
4829 argument is passed according to the corresponding formal
4830 argument. If the corresponding formal argument is a POINTER,
4831 ALLOCATABLE or assumed shape, we do not use g77's calling
4832 convention, and pass the address of the array descriptor
4833 instead. Otherwise we use g77's calling convention, in other words
4834 pass the array data pointer without descriptor. */
4835 bool nodesc_arg
= fsym
!= NULL
4836 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4838 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4839 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4841 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4843 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4845 /* Class array expressions are sometimes coming completely unadorned
4846 with either arrayspec or _data component. Correct that here.
4847 OOP-TODO: Move this to the frontend. */
4848 if (e
&& e
->expr_type
== EXPR_VARIABLE
4850 && e
->ts
.type
== BT_CLASS
4851 && (CLASS_DATA (e
)->attr
.codimension
4852 || CLASS_DATA (e
)->attr
.dimension
))
4854 gfc_typespec temp_ts
= e
->ts
;
4855 gfc_add_class_array_ref (e
);
4861 if (se
->ignore_optional
)
4863 /* Some intrinsics have already been resolved to the correct
4867 else if (arg
->label
)
4869 has_alternate_specifier
= 1;
4874 gfc_init_se (&parmse
, NULL
);
4876 /* For scalar arguments with VALUE attribute which are passed by
4877 value, pass "0" and a hidden argument gives the optional
4879 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4880 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4881 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4883 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4885 vec_safe_push (optionalargs
, boolean_false_node
);
4889 /* Pass a NULL pointer for an absent arg. */
4890 parmse
.expr
= null_pointer_node
;
4891 if (arg
->missing_arg_type
== BT_CHARACTER
)
4892 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4897 else if (arg
->expr
->expr_type
== EXPR_NULL
4898 && fsym
&& !fsym
->attr
.pointer
4899 && (fsym
->ts
.type
!= BT_CLASS
4900 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4902 /* Pass a NULL pointer to denote an absent arg. */
4903 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4904 && (fsym
->ts
.type
!= BT_CLASS
4905 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4906 gfc_init_se (&parmse
, NULL
);
4907 parmse
.expr
= null_pointer_node
;
4908 if (arg
->missing_arg_type
== BT_CHARACTER
)
4909 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4911 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4912 && e
->ts
.type
== BT_DERIVED
)
4914 /* The derived type needs to be converted to a temporary
4916 gfc_init_se (&parmse
, se
);
4917 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4919 && e
->expr_type
== EXPR_VARIABLE
4920 && e
->symtree
->n
.sym
->attr
.optional
,
4921 CLASS_DATA (fsym
)->attr
.class_pointer
4922 || CLASS_DATA (fsym
)->attr
.allocatable
);
4924 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4926 /* The intrinsic type needs to be converted to a temporary
4927 CLASS object for the unlimited polymorphic formal. */
4928 gfc_init_se (&parmse
, se
);
4929 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4931 else if (se
->ss
&& se
->ss
->info
->useflags
)
4937 /* An elemental function inside a scalarized loop. */
4938 gfc_init_se (&parmse
, se
);
4939 parm_kind
= ELEMENTAL
;
4941 /* When no fsym is present, ulim_copy is set and this is a third or
4942 fourth argument, use call-by-value instead of by reference to
4943 hand the length properties to the copy routine (i.e., most of the
4944 time this will be a call to a __copy_character_* routine where the
4945 third and fourth arguments are the lengths of a deferred length
4947 if ((fsym
&& fsym
->attr
.value
)
4948 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4949 gfc_conv_expr (&parmse
, e
);
4951 gfc_conv_expr_reference (&parmse
, e
);
4953 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4954 && e
->expr_type
== EXPR_FUNCTION
)
4955 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4958 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4959 && gfc_is_class_container_ref (e
))
4961 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4963 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4964 && e
->symtree
->n
.sym
->attr
.optional
)
4966 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4967 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4968 TREE_TYPE (parmse
.expr
),
4970 fold_convert (TREE_TYPE (parmse
.expr
),
4971 null_pointer_node
));
4975 /* If we are passing an absent array as optional dummy to an
4976 elemental procedure, make sure that we pass NULL when the data
4977 pointer is NULL. We need this extra conditional because of
4978 scalarization which passes arrays elements to the procedure,
4979 ignoring the fact that the array can be absent/unallocated/... */
4980 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4982 tree descriptor_data
;
4984 descriptor_data
= ss
->info
->data
.array
.data
;
4985 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4987 fold_convert (TREE_TYPE (descriptor_data
),
4988 null_pointer_node
));
4990 = fold_build3_loc (input_location
, COND_EXPR
,
4991 TREE_TYPE (parmse
.expr
),
4992 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4993 fold_convert (TREE_TYPE (parmse
.expr
),
4998 /* The scalarizer does not repackage the reference to a class
4999 array - instead it returns a pointer to the data element. */
5000 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5001 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5002 fsym
->attr
.intent
!= INTENT_IN
5003 && (CLASS_DATA (fsym
)->attr
.class_pointer
5004 || CLASS_DATA (fsym
)->attr
.allocatable
),
5006 && e
->expr_type
== EXPR_VARIABLE
5007 && e
->symtree
->n
.sym
->attr
.optional
,
5008 CLASS_DATA (fsym
)->attr
.class_pointer
5009 || CLASS_DATA (fsym
)->attr
.allocatable
);
5016 gfc_init_se (&parmse
, NULL
);
5018 /* Check whether the expression is a scalar or not; we cannot use
5019 e->rank as it can be nonzero for functions arguments. */
5020 argss
= gfc_walk_expr (e
);
5021 scalar
= argss
== gfc_ss_terminator
;
5023 gfc_free_ss_chain (argss
);
5025 /* Special handling for passing scalar polymorphic coarrays;
5026 otherwise one passes "class->_data.data" instead of "&class". */
5027 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5028 && fsym
&& fsym
->ts
.type
== BT_CLASS
5029 && CLASS_DATA (fsym
)->attr
.codimension
5030 && !CLASS_DATA (fsym
)->attr
.dimension
)
5032 gfc_add_class_array_ref (e
);
5033 parmse
.want_coarray
= 1;
5037 /* A scalar or transformational function. */
5040 if (e
->expr_type
== EXPR_VARIABLE
5041 && e
->symtree
->n
.sym
->attr
.cray_pointee
5042 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5044 /* The Cray pointer needs to be converted to a pointer to
5045 a type given by the expression. */
5046 gfc_conv_expr (&parmse
, e
);
5047 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5048 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5049 parmse
.expr
= convert (type
, tmp
);
5051 else if (fsym
&& fsym
->attr
.value
)
5053 if (fsym
->ts
.type
== BT_CHARACTER
5054 && fsym
->ts
.is_c_interop
5055 && fsym
->ns
->proc_name
!= NULL
5056 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5059 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5060 if (parmse
.expr
== NULL
)
5061 gfc_conv_expr (&parmse
, e
);
5065 gfc_conv_expr (&parmse
, e
);
5066 if (fsym
->attr
.optional
5067 && fsym
->ts
.type
!= BT_CLASS
5068 && fsym
->ts
.type
!= BT_DERIVED
)
5070 if (e
->expr_type
!= EXPR_VARIABLE
5071 || !e
->symtree
->n
.sym
->attr
.optional
5073 vec_safe_push (optionalargs
, boolean_true_node
);
5076 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5077 if (!e
->symtree
->n
.sym
->attr
.value
)
5079 = fold_build3_loc (input_location
, COND_EXPR
,
5080 TREE_TYPE (parmse
.expr
),
5082 fold_convert (TREE_TYPE (parmse
.expr
),
5083 integer_zero_node
));
5085 vec_safe_push (optionalargs
, tmp
);
5090 else if (arg
->name
&& arg
->name
[0] == '%')
5091 /* Argument list functions %VAL, %LOC and %REF are signalled
5092 through arg->name. */
5093 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5094 else if ((e
->expr_type
== EXPR_FUNCTION
)
5095 && ((e
->value
.function
.esym
5096 && e
->value
.function
.esym
->result
->attr
.pointer
)
5097 || (!e
->value
.function
.esym
5098 && e
->symtree
->n
.sym
->attr
.pointer
))
5099 && fsym
&& fsym
->attr
.target
)
5101 gfc_conv_expr (&parmse
, e
);
5102 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5104 else if (e
->expr_type
== EXPR_FUNCTION
5105 && e
->symtree
->n
.sym
->result
5106 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5107 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5109 /* Functions returning procedure pointers. */
5110 gfc_conv_expr (&parmse
, e
);
5111 if (fsym
&& fsym
->attr
.proc_pointer
)
5112 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5116 if (e
->ts
.type
== BT_CLASS
&& fsym
5117 && fsym
->ts
.type
== BT_CLASS
5118 && (!CLASS_DATA (fsym
)->as
5119 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5120 && CLASS_DATA (e
)->attr
.codimension
)
5122 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5123 gcc_assert (!CLASS_DATA (fsym
)->as
);
5124 gfc_add_class_array_ref (e
);
5125 parmse
.want_coarray
= 1;
5126 gfc_conv_expr_reference (&parmse
, e
);
5127 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5129 && e
->expr_type
== EXPR_VARIABLE
);
5131 else if (e
->ts
.type
== BT_CLASS
&& fsym
5132 && fsym
->ts
.type
== BT_CLASS
5133 && !CLASS_DATA (fsym
)->as
5134 && !CLASS_DATA (e
)->as
5135 && strcmp (fsym
->ts
.u
.derived
->name
,
5136 e
->ts
.u
.derived
->name
))
5138 type
= gfc_typenode_for_spec (&fsym
->ts
);
5139 var
= gfc_create_var (type
, fsym
->name
);
5140 gfc_conv_expr (&parmse
, e
);
5141 if (fsym
->attr
.optional
5142 && e
->expr_type
== EXPR_VARIABLE
5143 && e
->symtree
->n
.sym
->attr
.optional
)
5147 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5148 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5149 boolean_type_node
, tmp
,
5150 fold_convert (TREE_TYPE (tmp
),
5151 null_pointer_node
));
5152 gfc_start_block (&block
);
5153 gfc_add_modify (&block
, var
,
5154 fold_build1_loc (input_location
,
5156 type
, parmse
.expr
));
5157 gfc_add_expr_to_block (&parmse
.pre
,
5158 fold_build3_loc (input_location
,
5159 COND_EXPR
, void_type_node
,
5160 cond
, gfc_finish_block (&block
),
5161 build_empty_stmt (input_location
)));
5162 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5163 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5164 TREE_TYPE (parmse
.expr
),
5166 fold_convert (TREE_TYPE (parmse
.expr
),
5167 null_pointer_node
));
5171 gfc_add_modify (&parmse
.pre
, var
,
5172 fold_build1_loc (input_location
,
5174 type
, parmse
.expr
));
5175 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5179 gfc_conv_expr_reference (&parmse
, e
);
5181 /* Catch base objects that are not variables. */
5182 if (e
->ts
.type
== BT_CLASS
5183 && e
->expr_type
!= EXPR_VARIABLE
5184 && expr
&& e
== expr
->base_expr
)
5185 base_object
= build_fold_indirect_ref_loc (input_location
,
5188 /* A class array element needs converting back to be a
5189 class object, if the formal argument is a class object. */
5190 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5191 && e
->ts
.type
== BT_CLASS
5192 && ((CLASS_DATA (fsym
)->as
5193 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5194 || CLASS_DATA (e
)->attr
.dimension
))
5195 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5196 fsym
->attr
.intent
!= INTENT_IN
5197 && (CLASS_DATA (fsym
)->attr
.class_pointer
5198 || CLASS_DATA (fsym
)->attr
.allocatable
),
5200 && e
->expr_type
== EXPR_VARIABLE
5201 && e
->symtree
->n
.sym
->attr
.optional
,
5202 CLASS_DATA (fsym
)->attr
.class_pointer
5203 || CLASS_DATA (fsym
)->attr
.allocatable
);
5205 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5206 allocated on entry, it must be deallocated. */
5207 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5208 && (fsym
->attr
.allocatable
5209 || (fsym
->ts
.type
== BT_CLASS
5210 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5215 gfc_init_block (&block
);
5217 if (e
->ts
.type
== BT_CLASS
)
5218 ptr
= gfc_class_data_get (ptr
);
5220 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5223 gfc_add_expr_to_block (&block
, tmp
);
5224 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5225 void_type_node
, ptr
,
5227 gfc_add_expr_to_block (&block
, tmp
);
5229 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5231 gfc_add_modify (&block
, ptr
,
5232 fold_convert (TREE_TYPE (ptr
),
5233 null_pointer_node
));
5234 gfc_add_expr_to_block (&block
, tmp
);
5236 else if (fsym
->ts
.type
== BT_CLASS
)
5239 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5240 tmp
= gfc_get_symbol_decl (vtab
);
5241 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5242 ptr
= gfc_class_vptr_get (parmse
.expr
);
5243 gfc_add_modify (&block
, ptr
,
5244 fold_convert (TREE_TYPE (ptr
), tmp
));
5245 gfc_add_expr_to_block (&block
, tmp
);
5248 if (fsym
->attr
.optional
5249 && e
->expr_type
== EXPR_VARIABLE
5250 && e
->symtree
->n
.sym
->attr
.optional
)
5252 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5254 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5255 gfc_finish_block (&block
),
5256 build_empty_stmt (input_location
));
5259 tmp
= gfc_finish_block (&block
);
5261 gfc_add_expr_to_block (&se
->pre
, tmp
);
5264 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5265 || fsym
->ts
.type
== BT_ASSUMED
)
5266 && e
->ts
.type
== BT_CLASS
5267 && !CLASS_DATA (e
)->attr
.dimension
5268 && !CLASS_DATA (e
)->attr
.codimension
)
5269 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5271 /* Wrap scalar variable in a descriptor. We need to convert
5272 the address of a pointer back to the pointer itself before,
5273 we can assign it to the data field. */
5275 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5276 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5279 if (TREE_CODE (tmp
) == ADDR_EXPR
5280 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5281 tmp
= TREE_OPERAND (tmp
, 0);
5282 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5284 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5287 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5288 && ((fsym
->attr
.pointer
5289 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5290 || (fsym
->attr
.proc_pointer
5291 && !(e
->expr_type
== EXPR_VARIABLE
5292 && e
->symtree
->n
.sym
->attr
.dummy
))
5293 || (fsym
->attr
.proc_pointer
5294 && e
->expr_type
== EXPR_VARIABLE
5295 && gfc_is_proc_ptr_comp (e
))
5296 || (fsym
->attr
.allocatable
5297 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5299 /* Scalar pointer dummy args require an extra level of
5300 indirection. The null pointer already contains
5301 this level of indirection. */
5302 parm_kind
= SCALAR_POINTER
;
5303 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5307 else if (e
->ts
.type
== BT_CLASS
5308 && fsym
&& fsym
->ts
.type
== BT_CLASS
5309 && (CLASS_DATA (fsym
)->attr
.dimension
5310 || CLASS_DATA (fsym
)->attr
.codimension
))
5312 /* Pass a class array. */
5313 parmse
.use_offset
= 1;
5314 gfc_conv_expr_descriptor (&parmse
, e
);
5316 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5317 allocated on entry, it must be deallocated. */
5318 if (fsym
->attr
.intent
== INTENT_OUT
5319 && CLASS_DATA (fsym
)->attr
.allocatable
)
5324 gfc_init_block (&block
);
5326 ptr
= gfc_class_data_get (ptr
);
5328 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5329 NULL_TREE
, NULL_TREE
,
5331 GFC_CAF_COARRAY_NOCOARRAY
);
5332 gfc_add_expr_to_block (&block
, tmp
);
5333 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5334 void_type_node
, ptr
,
5336 gfc_add_expr_to_block (&block
, tmp
);
5337 gfc_reset_vptr (&block
, e
);
5339 if (fsym
->attr
.optional
5340 && e
->expr_type
== EXPR_VARIABLE
5342 || (e
->ref
->type
== REF_ARRAY
5343 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5344 && e
->symtree
->n
.sym
->attr
.optional
)
5346 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5348 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5349 gfc_finish_block (&block
),
5350 build_empty_stmt (input_location
));
5353 tmp
= gfc_finish_block (&block
);
5355 gfc_add_expr_to_block (&se
->pre
, tmp
);
5358 /* The conversion does not repackage the reference to a class
5359 array - _data descriptor. */
5360 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5361 fsym
->attr
.intent
!= INTENT_IN
5362 && (CLASS_DATA (fsym
)->attr
.class_pointer
5363 || CLASS_DATA (fsym
)->attr
.allocatable
),
5365 && e
->expr_type
== EXPR_VARIABLE
5366 && e
->symtree
->n
.sym
->attr
.optional
,
5367 CLASS_DATA (fsym
)->attr
.class_pointer
5368 || CLASS_DATA (fsym
)->attr
.allocatable
);
5372 /* If the argument is a function call that may not create
5373 a temporary for the result, we have to check that we
5374 can do it, i.e. that there is no alias between this
5375 argument and another one. */
5376 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5382 intent
= fsym
->attr
.intent
;
5384 intent
= INTENT_UNKNOWN
;
5386 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5388 parmse
.force_tmp
= 1;
5390 iarg
= e
->value
.function
.actual
->expr
;
5392 /* Temporary needed if aliasing due to host association. */
5393 if (sym
->attr
.contained
5395 && !sym
->attr
.implicit_pure
5396 && !sym
->attr
.use_assoc
5397 && iarg
->expr_type
== EXPR_VARIABLE
5398 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5399 parmse
.force_tmp
= 1;
5401 /* Ditto within module. */
5402 if (sym
->attr
.use_assoc
5404 && !sym
->attr
.implicit_pure
5405 && iarg
->expr_type
== EXPR_VARIABLE
5406 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5407 parmse
.force_tmp
= 1;
5410 if (e
->expr_type
== EXPR_VARIABLE
5411 && is_subref_array (e
))
5412 /* The actual argument is a component reference to an
5413 array of derived types. In this case, the argument
5414 is converted to a temporary, which is passed and then
5415 written back after the procedure call. */
5416 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5417 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5418 fsym
&& fsym
->attr
.pointer
);
5419 else if (gfc_is_class_array_ref (e
, NULL
)
5420 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5421 /* The actual argument is a component reference to an
5422 array of derived types. In this case, the argument
5423 is converted to a temporary, which is passed and then
5424 written back after the procedure call.
5425 OOP-TODO: Insert code so that if the dynamic type is
5426 the same as the declared type, copy-in/copy-out does
5428 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5429 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5430 fsym
&& fsym
->attr
.pointer
);
5432 else if (gfc_is_alloc_class_array_function (e
)
5433 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5434 /* See previous comment. For function actual argument,
5435 the write out is not needed so the intent is set as
5438 e
->must_finalize
= 1;
5439 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5441 fsym
&& fsym
->attr
.pointer
);
5444 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5447 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5448 allocated on entry, it must be deallocated. */
5449 if (fsym
&& fsym
->attr
.allocatable
5450 && fsym
->attr
.intent
== INTENT_OUT
)
5452 tmp
= build_fold_indirect_ref_loc (input_location
,
5454 tmp
= gfc_trans_dealloc_allocated (tmp
, e
,
5455 GFC_CAF_COARRAY_NOCOARRAY
);
5456 if (fsym
->attr
.optional
5457 && e
->expr_type
== EXPR_VARIABLE
5458 && e
->symtree
->n
.sym
->attr
.optional
)
5459 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5461 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5462 tmp
, build_empty_stmt (input_location
));
5463 gfc_add_expr_to_block (&se
->pre
, tmp
);
5468 /* The case with fsym->attr.optional is that of a user subroutine
5469 with an interface indicating an optional argument. When we call
5470 an intrinsic subroutine, however, fsym is NULL, but we might still
5471 have an optional argument, so we proceed to the substitution
5473 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5475 /* If an optional argument is itself an optional dummy argument,
5476 check its presence and substitute a null if absent. This is
5477 only needed when passing an array to an elemental procedure
5478 as then array elements are accessed - or no NULL pointer is
5479 allowed and a "1" or "0" should be passed if not present.
5480 When passing a non-array-descriptor full array to a
5481 non-array-descriptor dummy, no check is needed. For
5482 array-descriptor actual to array-descriptor dummy, see
5483 PR 41911 for why a check has to be inserted.
5484 fsym == NULL is checked as intrinsics required the descriptor
5485 but do not always set fsym. */
5486 if (e
->expr_type
== EXPR_VARIABLE
5487 && e
->symtree
->n
.sym
->attr
.optional
5488 && ((e
->rank
!= 0 && elemental_proc
)
5489 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5493 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5494 || fsym
->as
->type
== AS_ASSUMED_RANK
5495 || fsym
->as
->type
== AS_DEFERRED
))))))
5496 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5497 e
->representation
.length
);
5502 /* Obtain the character length of an assumed character length
5503 length procedure from the typespec. */
5504 if (fsym
->ts
.type
== BT_CHARACTER
5505 && parmse
.string_length
== NULL_TREE
5506 && e
->ts
.type
== BT_PROCEDURE
5507 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5508 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5509 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5511 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5512 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5516 if (fsym
&& need_interface_mapping
&& e
)
5517 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5519 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5520 gfc_add_block_to_block (&post
, &parmse
.post
);
5522 /* Allocated allocatable components of derived types must be
5523 deallocated for non-variable scalars, array arguments to elemental
5524 procedures, and array arguments with descriptor to non-elemental
5525 procedures. As bounds information for descriptorless arrays is no
5526 longer available here, they are dealt with in trans-array.c
5527 (gfc_conv_array_parameter). */
5528 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5529 && e
->ts
.u
.derived
->attr
.alloc_comp
5530 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5531 && !expr_may_alias_variables (e
, elemental_proc
))
5534 /* It is known the e returns a structure type with at least one
5535 allocatable component. When e is a function, ensure that the
5536 function is called once only by using a temporary variable. */
5537 if (!DECL_P (parmse
.expr
))
5538 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5539 parmse
.expr
, &se
->pre
);
5541 if (fsym
&& fsym
->attr
.value
)
5544 tmp
= build_fold_indirect_ref_loc (input_location
,
5547 parm_rank
= e
->rank
;
5555 case (SCALAR_POINTER
):
5556 tmp
= build_fold_indirect_ref_loc (input_location
,
5561 if (e
->expr_type
== EXPR_OP
5562 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5563 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5566 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5567 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5569 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5572 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5574 /* The derived type is passed to gfc_deallocate_alloc_comp.
5575 Therefore, class actuals can handled correctly but derived
5576 types passed to class formals need the _data component. */
5577 tmp
= gfc_class_data_get (tmp
);
5578 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5579 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5582 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5584 gfc_prepend_expr_to_block (&post
, tmp
);
5587 /* Add argument checking of passing an unallocated/NULL actual to
5588 a nonallocatable/nonpointer dummy. */
5590 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5592 symbol_attribute attr
;
5596 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5597 attr
= gfc_expr_attr (e
);
5599 goto end_pointer_check
;
5601 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5602 allocatable to an optional dummy, cf. 12.5.2.12. */
5603 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5604 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5605 goto end_pointer_check
;
5609 /* If the actual argument is an optional pointer/allocatable and
5610 the formal argument takes an nonpointer optional value,
5611 it is invalid to pass a non-present argument on, even
5612 though there is no technical reason for this in gfortran.
5613 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5614 tree present
, null_ptr
, type
;
5616 if (attr
.allocatable
5617 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5618 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5619 "allocated or not present",
5620 e
->symtree
->n
.sym
->name
);
5621 else if (attr
.pointer
5622 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5623 msg
= xasprintf ("Pointer actual argument '%s' is not "
5624 "associated or not present",
5625 e
->symtree
->n
.sym
->name
);
5626 else if (attr
.proc_pointer
5627 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5628 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5629 "associated or not present",
5630 e
->symtree
->n
.sym
->name
);
5632 goto end_pointer_check
;
5634 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5635 type
= TREE_TYPE (present
);
5636 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5637 boolean_type_node
, present
,
5639 null_pointer_node
));
5640 type
= TREE_TYPE (parmse
.expr
);
5641 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5642 boolean_type_node
, parmse
.expr
,
5644 null_pointer_node
));
5645 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5646 boolean_type_node
, present
, null_ptr
);
5650 if (attr
.allocatable
5651 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5652 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5653 "allocated", e
->symtree
->n
.sym
->name
);
5654 else if (attr
.pointer
5655 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5656 msg
= xasprintf ("Pointer actual argument '%s' is not "
5657 "associated", e
->symtree
->n
.sym
->name
);
5658 else if (attr
.proc_pointer
5659 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5660 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5661 "associated", e
->symtree
->n
.sym
->name
);
5663 goto end_pointer_check
;
5667 /* If the argument is passed by value, we need to strip the
5669 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5670 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5672 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5673 boolean_type_node
, tmp
,
5674 fold_convert (TREE_TYPE (tmp
),
5675 null_pointer_node
));
5678 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5684 /* Deferred length dummies pass the character length by reference
5685 so that the value can be returned. */
5686 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5688 if (INDIRECT_REF_P (parmse
.string_length
))
5689 /* In chains of functions/procedure calls the string_length already
5690 is a pointer to the variable holding the length. Therefore
5691 remove the deref on call. */
5692 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5695 tmp
= parmse
.string_length
;
5696 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5697 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5698 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5702 /* Character strings are passed as two parameters, a length and a
5703 pointer - except for Bind(c) which only passes the pointer.
5704 An unlimited polymorphic formal argument likewise does not
5706 if (parmse
.string_length
!= NULL_TREE
5707 && !sym
->attr
.is_bind_c
5708 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5709 vec_safe_push (stringargs
, parmse
.string_length
);
5711 /* When calling __copy for character expressions to unlimited
5712 polymorphic entities, the dst argument needs a string length. */
5713 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5714 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5715 && arg
->next
&& arg
->next
->expr
5716 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5717 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5718 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5719 vec_safe_push (stringargs
, parmse
.string_length
);
5721 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5722 pass the token and the offset as additional arguments. */
5723 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5724 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5725 && !fsym
->attr
.allocatable
)
5726 || (fsym
->ts
.type
== BT_CLASS
5727 && CLASS_DATA (fsym
)->attr
.codimension
5728 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5730 /* Token and offset. */
5731 vec_safe_push (stringargs
, null_pointer_node
);
5732 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5733 gcc_assert (fsym
->attr
.optional
);
5735 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5736 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5737 && !fsym
->attr
.allocatable
)
5738 || (fsym
->ts
.type
== BT_CLASS
5739 && CLASS_DATA (fsym
)->attr
.codimension
5740 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5742 tree caf_decl
, caf_type
;
5745 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5746 caf_type
= TREE_TYPE (caf_decl
);
5748 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5749 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5750 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5751 tmp
= gfc_conv_descriptor_token (caf_decl
);
5752 else if (DECL_LANG_SPECIFIC (caf_decl
)
5753 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5754 tmp
= GFC_DECL_TOKEN (caf_decl
);
5757 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5758 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5759 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5762 vec_safe_push (stringargs
, tmp
);
5764 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5765 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5766 offset
= build_int_cst (gfc_array_index_type
, 0);
5767 else if (DECL_LANG_SPECIFIC (caf_decl
)
5768 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5769 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5770 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5771 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5773 offset
= build_int_cst (gfc_array_index_type
, 0);
5775 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5776 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5779 gcc_assert (POINTER_TYPE_P (caf_type
));
5783 tmp2
= fsym
->ts
.type
== BT_CLASS
5784 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5785 if ((fsym
->ts
.type
!= BT_CLASS
5786 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5787 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5788 || (fsym
->ts
.type
== BT_CLASS
5789 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5790 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5792 if (fsym
->ts
.type
== BT_CLASS
)
5793 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5796 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5797 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5799 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5800 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5802 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5803 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5806 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5809 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5810 gfc_array_index_type
,
5811 fold_convert (gfc_array_index_type
, tmp2
),
5812 fold_convert (gfc_array_index_type
, tmp
));
5813 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5814 gfc_array_index_type
, offset
, tmp
);
5816 vec_safe_push (stringargs
, offset
);
5819 vec_safe_push (arglist
, parmse
.expr
);
5821 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5825 else if (sym
->ts
.type
== BT_CLASS
)
5826 ts
= CLASS_DATA (sym
)->ts
;
5830 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5831 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5832 else if (ts
.type
== BT_CHARACTER
)
5834 if (ts
.u
.cl
->length
== NULL
)
5836 /* Assumed character length results are not allowed by 5.1.1.5 of the
5837 standard and are trapped in resolve.c; except in the case of SPREAD
5838 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5839 we take the character length of the first argument for the result.
5840 For dummies, we have to look through the formal argument list for
5841 this function and use the character length found there.*/
5843 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5844 else if (!sym
->attr
.dummy
)
5845 cl
.backend_decl
= (*stringargs
)[0];
5848 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5849 for (; formal
; formal
= formal
->next
)
5850 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5851 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5853 len
= cl
.backend_decl
;
5859 /* Calculate the length of the returned string. */
5860 gfc_init_se (&parmse
, NULL
);
5861 if (need_interface_mapping
)
5862 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5864 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5865 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5866 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5868 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5869 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5870 gfc_charlen_type_node
, tmp
,
5871 build_int_cst (gfc_charlen_type_node
, 0));
5872 cl
.backend_decl
= tmp
;
5875 /* Set up a charlen structure for it. */
5880 len
= cl
.backend_decl
;
5883 byref
= (comp
&& (comp
->attr
.dimension
5884 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5885 || (!comp
&& gfc_return_by_reference (sym
));
5888 if (se
->direct_byref
)
5890 /* Sometimes, too much indirection can be applied; e.g. for
5891 function_result = array_valued_recursive_function. */
5892 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5893 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5894 && GFC_DESCRIPTOR_TYPE_P
5895 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5896 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5899 /* If the lhs of an assignment x = f(..) is allocatable and
5900 f2003 is allowed, we must do the automatic reallocation.
5901 TODO - deal with intrinsics, without using a temporary. */
5902 if (flag_realloc_lhs
5903 && se
->ss
&& se
->ss
->loop_chain
5904 && se
->ss
->loop_chain
->is_alloc_lhs
5905 && !expr
->value
.function
.isym
5906 && sym
->result
->as
!= NULL
)
5908 /* Evaluate the bounds of the result, if known. */
5909 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5912 /* Perform the automatic reallocation. */
5913 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5915 gfc_add_expr_to_block (&se
->pre
, tmp
);
5917 /* Pass the temporary as the first argument. */
5918 result
= info
->descriptor
;
5921 result
= build_fold_indirect_ref_loc (input_location
,
5923 vec_safe_push (retargs
, se
->expr
);
5925 else if (comp
&& comp
->attr
.dimension
)
5927 gcc_assert (se
->loop
&& info
);
5929 /* Set the type of the array. */
5930 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5931 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5933 /* Evaluate the bounds of the result, if known. */
5934 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5936 /* If the lhs of an assignment x = f(..) is allocatable and
5937 f2003 is allowed, we must not generate the function call
5938 here but should just send back the results of the mapping.
5939 This is signalled by the function ss being flagged. */
5940 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5942 gfc_free_interface_mapping (&mapping
);
5943 return has_alternate_specifier
;
5946 /* Create a temporary to store the result. In case the function
5947 returns a pointer, the temporary will be a shallow copy and
5948 mustn't be deallocated. */
5949 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5950 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5951 tmp
, NULL_TREE
, false,
5952 !comp
->attr
.pointer
, callee_alloc
,
5953 &se
->ss
->info
->expr
->where
);
5955 /* Pass the temporary as the first argument. */
5956 result
= info
->descriptor
;
5957 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5958 vec_safe_push (retargs
, tmp
);
5960 else if (!comp
&& sym
->result
->attr
.dimension
)
5962 gcc_assert (se
->loop
&& info
);
5964 /* Set the type of the array. */
5965 tmp
= gfc_typenode_for_spec (&ts
);
5966 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5968 /* Evaluate the bounds of the result, if known. */
5969 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5971 /* If the lhs of an assignment x = f(..) is allocatable and
5972 f2003 is allowed, we must not generate the function call
5973 here but should just send back the results of the mapping.
5974 This is signalled by the function ss being flagged. */
5975 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5977 gfc_free_interface_mapping (&mapping
);
5978 return has_alternate_specifier
;
5981 /* Create a temporary to store the result. In case the function
5982 returns a pointer, the temporary will be a shallow copy and
5983 mustn't be deallocated. */
5984 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5985 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5986 tmp
, NULL_TREE
, false,
5987 !sym
->attr
.pointer
, callee_alloc
,
5988 &se
->ss
->info
->expr
->where
);
5990 /* Pass the temporary as the first argument. */
5991 result
= info
->descriptor
;
5992 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5993 vec_safe_push (retargs
, tmp
);
5995 else if (ts
.type
== BT_CHARACTER
)
5997 /* Pass the string length. */
5998 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5999 type
= build_pointer_type (type
);
6001 /* Return an address to a char[0:len-1]* temporary for
6002 character pointers. */
6003 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6004 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6006 var
= gfc_create_var (type
, "pstr");
6008 if ((!comp
&& sym
->attr
.allocatable
)
6009 || (comp
&& comp
->attr
.allocatable
))
6011 gfc_add_modify (&se
->pre
, var
,
6012 fold_convert (TREE_TYPE (var
),
6013 null_pointer_node
));
6014 tmp
= gfc_call_free (var
);
6015 gfc_add_expr_to_block (&se
->post
, tmp
);
6018 /* Provide an address expression for the function arguments. */
6019 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6022 var
= gfc_conv_string_tmp (se
, type
, len
);
6024 vec_safe_push (retargs
, var
);
6028 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6030 type
= gfc_get_complex_type (ts
.kind
);
6031 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6032 vec_safe_push (retargs
, var
);
6035 /* Add the string length to the argument list. */
6036 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6040 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6041 TREE_STATIC (tmp
) = 1;
6042 gfc_add_modify (&se
->pre
, tmp
,
6043 build_int_cst (TREE_TYPE (tmp
), 0));
6044 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6045 vec_safe_push (retargs
, tmp
);
6047 else if (ts
.type
== BT_CHARACTER
)
6048 vec_safe_push (retargs
, len
);
6050 gfc_free_interface_mapping (&mapping
);
6052 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6053 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6054 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6055 vec_safe_reserve (retargs
, arglen
);
6057 /* Add the return arguments. */
6058 vec_safe_splice (retargs
, arglist
);
6060 /* Add the hidden present status for optional+value to the arguments. */
6061 vec_safe_splice (retargs
, optionalargs
);
6063 /* Add the hidden string length parameters to the arguments. */
6064 vec_safe_splice (retargs
, stringargs
);
6066 /* We may want to append extra arguments here. This is used e.g. for
6067 calls to libgfortran_matmul_??, which need extra information. */
6068 vec_safe_splice (retargs
, append_args
);
6072 /* Generate the actual call. */
6073 if (base_object
== NULL_TREE
)
6074 conv_function_val (se
, sym
, expr
);
6076 conv_base_obj_fcn_val (se
, base_object
, expr
);
6078 /* If there are alternate return labels, function type should be
6079 integer. Can't modify the type in place though, since it can be shared
6080 with other functions. For dummy arguments, the typing is done to
6081 this result, even if it has to be repeated for each call. */
6082 if (has_alternate_specifier
6083 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6085 if (!sym
->attr
.dummy
)
6087 TREE_TYPE (sym
->backend_decl
)
6088 = build_function_type (integer_type_node
,
6089 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6090 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6093 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6096 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6097 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6099 /* Allocatable scalar function results must be freed and nullified
6100 after use. This necessitates the creation of a temporary to
6101 hold the result to prevent duplicate calls. */
6102 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6103 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6105 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6106 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6108 tmp
= gfc_call_free (tmp
);
6109 gfc_add_expr_to_block (&post
, tmp
);
6110 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6113 /* If we have a pointer function, but we don't want a pointer, e.g.
6116 where f is pointer valued, we have to dereference the result. */
6117 if (!se
->want_pointer
&& !byref
6118 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6119 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6120 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6122 /* f2c calling conventions require a scalar default real function to
6123 return a double precision result. Convert this back to default
6124 real. We only care about the cases that can happen in Fortran 77.
6126 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6127 && sym
->ts
.kind
== gfc_default_real_kind
6128 && !sym
->attr
.always_explicit
)
6129 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6131 /* A pure function may still have side-effects - it may modify its
6133 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6135 if (!sym
->attr
.pure
)
6136 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6141 /* Add the function call to the pre chain. There is no expression. */
6142 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6143 se
->expr
= NULL_TREE
;
6145 if (!se
->direct_byref
)
6147 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6149 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6151 /* Check the data pointer hasn't been modified. This would
6152 happen in a function returning a pointer. */
6153 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6154 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6157 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6160 se
->expr
= info
->descriptor
;
6161 /* Bundle in the string length. */
6162 se
->string_length
= len
;
6164 else if (ts
.type
== BT_CHARACTER
)
6166 /* Dereference for character pointer results. */
6167 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6168 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6169 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6173 se
->string_length
= len
;
6177 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6178 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6183 /* Associate the rhs class object's meta-data with the result, when the
6184 result is a temporary. */
6185 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6186 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6187 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6190 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6192 gfc_init_se (&parmse
, NULL
);
6193 parmse
.data_not_needed
= 1;
6194 gfc_conv_expr (&parmse
, class_expr
);
6195 if (!DECL_LANG_SPECIFIC (result
))
6196 gfc_allocate_lang_decl (result
);
6197 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6198 gfc_free_expr (class_expr
);
6199 gcc_assert (parmse
.pre
.head
== NULL_TREE
6200 && parmse
.post
.head
== NULL_TREE
);
6203 /* Follow the function call with the argument post block. */
6206 gfc_add_block_to_block (&se
->pre
, &post
);
6208 /* Transformational functions of derived types with allocatable
6209 components must have the result allocatable components copied. */
6210 arg
= expr
->value
.function
.actual
;
6211 if (result
&& arg
&& expr
->rank
6212 && expr
->value
.function
.isym
6213 && expr
->value
.function
.isym
->transformational
6214 && arg
->expr
->ts
.type
== BT_DERIVED
6215 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6218 /* Copy the allocatable components. We have to use a
6219 temporary here to prevent source allocatable components
6220 from being corrupted. */
6221 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6222 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6223 result
, tmp2
, expr
->rank
, 0);
6224 gfc_add_expr_to_block (&se
->pre
, tmp
);
6225 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6227 gfc_add_expr_to_block (&se
->pre
, tmp
);
6229 /* Finally free the temporary's data field. */
6230 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6231 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6232 NULL_TREE
, NULL_TREE
, true,
6233 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6234 gfc_add_expr_to_block (&se
->pre
, tmp
);
6239 /* For a function with a class array result, save the result as
6240 a temporary, set the info fields needed by the scalarizer and
6241 call the finalization function of the temporary. Note that the
6242 nullification of allocatable components needed by the result
6243 is done in gfc_trans_assignment_1. */
6244 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6245 && se
->ss
&& se
->ss
->loop
)
6246 || gfc_is_alloc_class_scalar_function (expr
))
6247 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6248 && expr
->must_finalize
)
6253 if (se
->ss
&& se
->ss
->loop
)
6255 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6256 tmp
= gfc_class_data_get (se
->expr
);
6257 info
->descriptor
= tmp
;
6258 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6259 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6260 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6262 tree dim
= gfc_rank_cst
[n
];
6263 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6264 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6269 /* TODO Eliminate the doubling of temporaries. This
6270 one is necessary to ensure no memory leakage. */
6271 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6272 tmp
= gfc_class_data_get (se
->expr
);
6273 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6274 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6277 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6278 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6281 fold_convert (TREE_TYPE (final_fndecl
),
6282 null_pointer_node
));
6283 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6285 tmp
= build_call_expr_loc (input_location
,
6287 gfc_build_addr_expr (NULL
, tmp
),
6288 gfc_class_vtab_size_get (se
->expr
),
6289 boolean_false_node
);
6290 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6291 void_type_node
, is_final
, tmp
,
6292 build_empty_stmt (input_location
));
6294 if (se
->ss
&& se
->ss
->loop
)
6296 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6297 tmp
= gfc_call_free (info
->data
);
6298 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6302 gfc_add_expr_to_block (&se
->post
, tmp
);
6303 tmp
= gfc_class_data_get (se
->expr
);
6304 tmp
= gfc_call_free (tmp
);
6305 gfc_add_expr_to_block (&se
->post
, tmp
);
6307 expr
->must_finalize
= 0;
6310 gfc_add_block_to_block (&se
->post
, &post
);
6313 return has_alternate_specifier
;
6317 /* Fill a character string with spaces. */
6320 fill_with_spaces (tree start
, tree type
, tree size
)
6322 stmtblock_t block
, loop
;
6323 tree i
, el
, exit_label
, cond
, tmp
;
6325 /* For a simple char type, we can call memset(). */
6326 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6327 return build_call_expr_loc (input_location
,
6328 builtin_decl_explicit (BUILT_IN_MEMSET
),
6330 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6331 lang_hooks
.to_target_charset (' ')),
6334 /* Otherwise, we use a loop:
6335 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6339 /* Initialize variables. */
6340 gfc_init_block (&block
);
6341 i
= gfc_create_var (sizetype
, "i");
6342 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6343 el
= gfc_create_var (build_pointer_type (type
), "el");
6344 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6345 exit_label
= gfc_build_label_decl (NULL_TREE
);
6346 TREE_USED (exit_label
) = 1;
6350 gfc_init_block (&loop
);
6352 /* Exit condition. */
6353 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6354 build_zero_cst (sizetype
));
6355 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6356 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6357 build_empty_stmt (input_location
));
6358 gfc_add_expr_to_block (&loop
, tmp
);
6361 gfc_add_modify (&loop
,
6362 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6363 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6365 /* Increment loop variables. */
6366 gfc_add_modify (&loop
, i
,
6367 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6368 TYPE_SIZE_UNIT (type
)));
6369 gfc_add_modify (&loop
, el
,
6370 fold_build_pointer_plus_loc (input_location
,
6371 el
, TYPE_SIZE_UNIT (type
)));
6373 /* Making the loop... actually loop! */
6374 tmp
= gfc_finish_block (&loop
);
6375 tmp
= build1_v (LOOP_EXPR
, tmp
);
6376 gfc_add_expr_to_block (&block
, tmp
);
6378 /* The exit label. */
6379 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6380 gfc_add_expr_to_block (&block
, tmp
);
6383 return gfc_finish_block (&block
);
6387 /* Generate code to copy a string. */
6390 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6391 int dkind
, tree slength
, tree src
, int skind
)
6393 tree tmp
, dlen
, slen
;
6402 stmtblock_t tempblock
;
6404 gcc_assert (dkind
== skind
);
6406 if (slength
!= NULL_TREE
)
6408 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6409 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6413 slen
= build_int_cst (size_type_node
, 1);
6417 if (dlength
!= NULL_TREE
)
6419 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6420 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6424 dlen
= build_int_cst (size_type_node
, 1);
6428 /* Assign directly if the types are compatible. */
6429 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6430 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6432 gfc_add_modify (block
, dsc
, ssc
);
6436 /* Do nothing if the destination length is zero. */
6437 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6438 build_int_cst (size_type_node
, 0));
6440 /* The following code was previously in _gfortran_copy_string:
6442 // The two strings may overlap so we use memmove.
6444 copy_string (GFC_INTEGER_4 destlen, char * dest,
6445 GFC_INTEGER_4 srclen, const char * src)
6447 if (srclen >= destlen)
6449 // This will truncate if too long.
6450 memmove (dest, src, destlen);
6454 memmove (dest, src, srclen);
6456 memset (&dest[srclen], ' ', destlen - srclen);
6460 We're now doing it here for better optimization, but the logic
6463 /* For non-default character kinds, we have to multiply the string
6464 length by the base type size. */
6465 chartype
= gfc_get_char_type (dkind
);
6466 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6467 fold_convert (size_type_node
, slen
),
6468 fold_convert (size_type_node
,
6469 TYPE_SIZE_UNIT (chartype
)));
6470 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6471 fold_convert (size_type_node
, dlen
),
6472 fold_convert (size_type_node
,
6473 TYPE_SIZE_UNIT (chartype
)));
6475 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6476 dest
= fold_convert (pvoid_type_node
, dest
);
6478 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6480 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6481 src
= fold_convert (pvoid_type_node
, src
);
6483 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6485 /* Truncate string if source is too long. */
6486 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6488 tmp2
= build_call_expr_loc (input_location
,
6489 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6490 3, dest
, src
, dlen
);
6492 /* Else copy and pad with spaces. */
6493 tmp3
= build_call_expr_loc (input_location
,
6494 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6495 3, dest
, src
, slen
);
6497 /* Wstringop-overflow appears at -O3 even though this warning is not
6498 explicitly available in fortran nor can it be switched off. If the
6499 source length is a constant, its negative appears as a very large
6500 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6501 the result of the MINUS_EXPR suppresses this spurious warning. */
6502 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6503 TREE_TYPE(dlen
), dlen
, slen
);
6504 if (slength
&& TREE_CONSTANT (slength
))
6505 tmp
= gfc_evaluate_now (tmp
, block
);
6507 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6508 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6510 gfc_init_block (&tempblock
);
6511 gfc_add_expr_to_block (&tempblock
, tmp3
);
6512 gfc_add_expr_to_block (&tempblock
, tmp4
);
6513 tmp3
= gfc_finish_block (&tempblock
);
6515 /* The whole copy_string function is there. */
6516 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6518 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6519 build_empty_stmt (input_location
));
6520 gfc_add_expr_to_block (block
, tmp
);
6524 /* Translate a statement function.
6525 The value of a statement function reference is obtained by evaluating the
6526 expression using the values of the actual arguments for the values of the
6527 corresponding dummy arguments. */
6530 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6534 gfc_formal_arglist
*fargs
;
6535 gfc_actual_arglist
*args
;
6538 gfc_saved_var
*saved_vars
;
6544 sym
= expr
->symtree
->n
.sym
;
6545 args
= expr
->value
.function
.actual
;
6546 gfc_init_se (&lse
, NULL
);
6547 gfc_init_se (&rse
, NULL
);
6550 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6552 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6553 temp_vars
= XCNEWVEC (tree
, n
);
6555 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6556 fargs
= fargs
->next
, n
++)
6558 /* Each dummy shall be specified, explicitly or implicitly, to be
6560 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6563 if (fsym
->ts
.type
== BT_CHARACTER
)
6565 /* Copy string arguments. */
6568 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6569 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6571 /* Create a temporary to hold the value. */
6572 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6573 fsym
->ts
.u
.cl
->backend_decl
6574 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6576 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6577 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6579 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6581 gfc_conv_expr (&rse
, args
->expr
);
6582 gfc_conv_string_parameter (&rse
);
6583 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6584 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6586 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6587 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6588 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6589 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6593 /* For everything else, just evaluate the expression. */
6595 /* Create a temporary to hold the value. */
6596 type
= gfc_typenode_for_spec (&fsym
->ts
);
6597 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6599 gfc_conv_expr (&lse
, args
->expr
);
6601 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6602 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6603 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6609 /* Use the temporary variables in place of the real ones. */
6610 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6611 fargs
= fargs
->next
, n
++)
6612 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6614 gfc_conv_expr (se
, sym
->value
);
6616 if (sym
->ts
.type
== BT_CHARACTER
)
6618 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6620 /* Force the expression to the correct length. */
6621 if (!INTEGER_CST_P (se
->string_length
)
6622 || tree_int_cst_lt (se
->string_length
,
6623 sym
->ts
.u
.cl
->backend_decl
))
6625 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6626 tmp
= gfc_create_var (type
, sym
->name
);
6627 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6628 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6629 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6633 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6636 /* Restore the original variables. */
6637 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6638 fargs
= fargs
->next
, n
++)
6639 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6645 /* Translate a function expression. */
6648 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6652 if (expr
->value
.function
.isym
)
6654 gfc_conv_intrinsic_function (se
, expr
);
6658 /* expr.value.function.esym is the resolved (specific) function symbol for
6659 most functions. However this isn't set for dummy procedures. */
6660 sym
= expr
->value
.function
.esym
;
6662 sym
= expr
->symtree
->n
.sym
;
6664 /* The IEEE_ARITHMETIC functions are caught here. */
6665 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6666 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6669 /* We distinguish statement functions from general functions to improve
6670 runtime performance. */
6671 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6673 gfc_conv_statement_function (se
, expr
);
6677 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6682 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6685 is_zero_initializer_p (gfc_expr
* expr
)
6687 if (expr
->expr_type
!= EXPR_CONSTANT
)
6690 /* We ignore constants with prescribed memory representations for now. */
6691 if (expr
->representation
.string
)
6694 switch (expr
->ts
.type
)
6697 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6700 return mpfr_zero_p (expr
->value
.real
)
6701 && MPFR_SIGN (expr
->value
.real
) >= 0;
6704 return expr
->value
.logical
== 0;
6707 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6708 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6709 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6710 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6720 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6725 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6726 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6728 gfc_conv_tmp_array_ref (se
);
6732 /* Build a static initializer. EXPR is the expression for the initial value.
6733 The other parameters describe the variable of the component being
6734 initialized. EXPR may be null. */
6737 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6738 bool array
, bool pointer
, bool procptr
)
6742 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6743 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6744 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6745 return build_constructor (type
, NULL
);
6747 if (!(expr
|| pointer
|| procptr
))
6750 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6751 (these are the only two iso_c_binding derived types that can be
6752 used as initialization expressions). If so, we need to modify
6753 the 'expr' to be that for a (void *). */
6754 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6755 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6757 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6759 /* The derived symbol has already been converted to a (void *). Use
6761 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6762 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6764 gfc_init_se (&se
, NULL
);
6765 gfc_conv_constant (&se
, expr
);
6766 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6770 if (array
&& !procptr
)
6773 /* Arrays need special handling. */
6775 ctor
= gfc_build_null_descriptor (type
);
6776 /* Special case assigning an array to zero. */
6777 else if (is_zero_initializer_p (expr
))
6778 ctor
= build_constructor (type
, NULL
);
6780 ctor
= gfc_conv_array_initializer (type
, expr
);
6781 TREE_STATIC (ctor
) = 1;
6784 else if (pointer
|| procptr
)
6786 if (ts
->type
== BT_CLASS
&& !procptr
)
6788 gfc_init_se (&se
, NULL
);
6789 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6790 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6791 TREE_STATIC (se
.expr
) = 1;
6794 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6795 return fold_convert (type
, null_pointer_node
);
6798 gfc_init_se (&se
, NULL
);
6799 se
.want_pointer
= 1;
6800 gfc_conv_expr (&se
, expr
);
6801 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6811 gfc_init_se (&se
, NULL
);
6812 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6813 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6815 gfc_conv_structure (&se
, expr
, 1);
6816 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6817 TREE_STATIC (se
.expr
) = 1;
6822 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6823 TREE_STATIC (ctor
) = 1;
6828 gfc_init_se (&se
, NULL
);
6829 gfc_conv_constant (&se
, expr
);
6830 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6837 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6843 gfc_array_info
*lss_array
;
6850 gfc_start_block (&block
);
6852 /* Initialize the scalarizer. */
6853 gfc_init_loopinfo (&loop
);
6855 gfc_init_se (&lse
, NULL
);
6856 gfc_init_se (&rse
, NULL
);
6859 rss
= gfc_walk_expr (expr
);
6860 if (rss
== gfc_ss_terminator
)
6861 /* The rhs is scalar. Add a ss for the expression. */
6862 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6864 /* Create a SS for the destination. */
6865 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6867 lss_array
= &lss
->info
->data
.array
;
6868 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6869 lss_array
->descriptor
= dest
;
6870 lss_array
->data
= gfc_conv_array_data (dest
);
6871 lss_array
->offset
= gfc_conv_array_offset (dest
);
6872 for (n
= 0; n
< cm
->as
->rank
; n
++)
6874 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6875 lss_array
->stride
[n
] = gfc_index_one_node
;
6877 mpz_init (lss_array
->shape
[n
]);
6878 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6879 cm
->as
->lower
[n
]->value
.integer
);
6880 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6883 /* Associate the SS with the loop. */
6884 gfc_add_ss_to_loop (&loop
, lss
);
6885 gfc_add_ss_to_loop (&loop
, rss
);
6887 /* Calculate the bounds of the scalarization. */
6888 gfc_conv_ss_startstride (&loop
);
6890 /* Setup the scalarizing loops. */
6891 gfc_conv_loop_setup (&loop
, &expr
->where
);
6893 /* Setup the gfc_se structures. */
6894 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6895 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6898 gfc_mark_ss_chain_used (rss
, 1);
6900 gfc_mark_ss_chain_used (lss
, 1);
6902 /* Start the scalarized loop body. */
6903 gfc_start_scalarized_body (&loop
, &body
);
6905 gfc_conv_tmp_array_ref (&lse
);
6906 if (cm
->ts
.type
== BT_CHARACTER
)
6907 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6909 gfc_conv_expr (&rse
, expr
);
6911 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6912 gfc_add_expr_to_block (&body
, tmp
);
6914 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6916 /* Generate the copying loops. */
6917 gfc_trans_scalarizing_loops (&loop
, &body
);
6919 /* Wrap the whole thing up. */
6920 gfc_add_block_to_block (&block
, &loop
.pre
);
6921 gfc_add_block_to_block (&block
, &loop
.post
);
6923 gcc_assert (lss_array
->shape
!= NULL
);
6924 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6925 gfc_cleanup_loop (&loop
);
6927 return gfc_finish_block (&block
);
6932 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6942 gfc_expr
*arg
= NULL
;
6944 gfc_start_block (&block
);
6945 gfc_init_se (&se
, NULL
);
6947 /* Get the descriptor for the expressions. */
6948 se
.want_pointer
= 0;
6949 gfc_conv_expr_descriptor (&se
, expr
);
6950 gfc_add_block_to_block (&block
, &se
.pre
);
6951 gfc_add_modify (&block
, dest
, se
.expr
);
6953 /* Deal with arrays of derived types with allocatable components. */
6954 if (gfc_bt_struct (cm
->ts
.type
)
6955 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6956 // TODO: Fix caf_mode
6957 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6960 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6961 && CLASS_DATA(cm
)->attr
.allocatable
)
6963 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6964 // TODO: Fix caf_mode
6965 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6970 tmp
= TREE_TYPE (dest
);
6971 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6972 tmp
, expr
->rank
, NULL_TREE
);
6976 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6977 TREE_TYPE(cm
->backend_decl
),
6978 cm
->as
->rank
, NULL_TREE
);
6980 gfc_add_expr_to_block (&block
, tmp
);
6981 gfc_add_block_to_block (&block
, &se
.post
);
6983 if (expr
->expr_type
!= EXPR_VARIABLE
)
6984 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6987 /* We need to know if the argument of a conversion function is a
6988 variable, so that the correct lower bound can be used. */
6989 if (expr
->expr_type
== EXPR_FUNCTION
6990 && expr
->value
.function
.isym
6991 && expr
->value
.function
.isym
->conversion
6992 && expr
->value
.function
.actual
->expr
6993 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6994 arg
= expr
->value
.function
.actual
->expr
;
6996 /* Obtain the array spec of full array references. */
6998 as
= gfc_get_full_arrayspec_from_expr (arg
);
7000 as
= gfc_get_full_arrayspec_from_expr (expr
);
7002 /* Shift the lbound and ubound of temporaries to being unity,
7003 rather than zero, based. Always calculate the offset. */
7004 offset
= gfc_conv_descriptor_offset_get (dest
);
7005 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7006 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7008 for (n
= 0; n
< expr
->rank
; n
++)
7013 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7014 TODO It looks as if gfc_conv_expr_descriptor should return
7015 the correct bounds and that the following should not be
7016 necessary. This would simplify gfc_conv_intrinsic_bound
7018 if (as
&& as
->lower
[n
])
7021 gfc_init_se (&lbse
, NULL
);
7022 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7023 gfc_add_block_to_block (&block
, &lbse
.pre
);
7024 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7028 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7029 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7033 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7036 lbound
= gfc_index_one_node
;
7038 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7040 /* Shift the bounds and set the offset accordingly. */
7041 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7042 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7043 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7044 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7046 gfc_conv_descriptor_ubound_set (&block
, dest
,
7047 gfc_rank_cst
[n
], tmp
);
7048 gfc_conv_descriptor_lbound_set (&block
, dest
,
7049 gfc_rank_cst
[n
], lbound
);
7051 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7052 gfc_conv_descriptor_lbound_get (dest
,
7054 gfc_conv_descriptor_stride_get (dest
,
7056 gfc_add_modify (&block
, tmp2
, tmp
);
7057 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7059 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7064 /* If a conversion expression has a null data pointer
7065 argument, nullify the allocatable component. */
7069 if (arg
->symtree
->n
.sym
->attr
.allocatable
7070 || arg
->symtree
->n
.sym
->attr
.pointer
)
7072 non_null_expr
= gfc_finish_block (&block
);
7073 gfc_start_block (&block
);
7074 gfc_conv_descriptor_data_set (&block
, dest
,
7076 null_expr
= gfc_finish_block (&block
);
7077 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7078 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
7079 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7080 return build3_v (COND_EXPR
, tmp
,
7081 null_expr
, non_null_expr
);
7085 return gfc_finish_block (&block
);
7089 /* Allocate or reallocate scalar component, as necessary. */
7092 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7102 tree lhs_cl_size
= NULL_TREE
;
7107 if (!expr2
|| expr2
->rank
)
7110 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7112 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7114 char name
[GFC_MAX_SYMBOL_LEN
+9];
7115 gfc_component
*strlen
;
7116 /* Use the rhs string length and the lhs element size. */
7117 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7118 if (!expr2
->ts
.u
.cl
->backend_decl
)
7120 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7121 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7124 size
= expr2
->ts
.u
.cl
->backend_decl
;
7126 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7128 sprintf (name
, "_%s_length", cm
->name
);
7129 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7130 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7131 gfc_charlen_type_node
,
7132 TREE_OPERAND (comp
, 0),
7133 strlen
->backend_decl
, NULL_TREE
);
7135 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7136 tmp
= TYPE_SIZE_UNIT (tmp
);
7137 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7138 TREE_TYPE (tmp
), tmp
,
7139 fold_convert (TREE_TYPE (tmp
), size
));
7141 else if (cm
->ts
.type
== BT_CLASS
)
7143 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7144 if (expr2
->ts
.type
== BT_DERIVED
)
7146 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7147 size
= TYPE_SIZE_UNIT (tmp
);
7153 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7154 gfc_add_vptr_component (e2vtab
);
7155 gfc_add_size_component (e2vtab
);
7156 gfc_init_se (&se
, NULL
);
7157 gfc_conv_expr (&se
, e2vtab
);
7158 gfc_add_block_to_block (block
, &se
.pre
);
7159 size
= fold_convert (size_type_node
, se
.expr
);
7160 gfc_free_expr (e2vtab
);
7162 size_in_bytes
= size
;
7166 /* Otherwise use the length in bytes of the rhs. */
7167 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7168 size_in_bytes
= size
;
7171 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7172 size_in_bytes
, size_one_node
);
7174 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7176 tmp
= build_call_expr_loc (input_location
,
7177 builtin_decl_explicit (BUILT_IN_CALLOC
),
7178 2, build_one_cst (size_type_node
),
7180 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7181 gfc_add_modify (block
, comp
, tmp
);
7185 tmp
= build_call_expr_loc (input_location
,
7186 builtin_decl_explicit (BUILT_IN_MALLOC
),
7188 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7189 ptr
= gfc_class_data_get (comp
);
7192 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7193 gfc_add_modify (block
, ptr
, tmp
);
7196 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7197 /* Update the lhs character length. */
7198 gfc_add_modify (block
, lhs_cl_size
, size
);
7202 /* Assign a single component of a derived type constructor. */
7205 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7206 gfc_symbol
*sym
, bool init
)
7214 gfc_start_block (&block
);
7216 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7218 /* Only care about pointers here, not about allocatables. */
7219 gfc_init_se (&se
, NULL
);
7220 /* Pointer component. */
7221 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7222 && !cm
->attr
.proc_pointer
)
7224 /* Array pointer. */
7225 if (expr
->expr_type
== EXPR_NULL
)
7226 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7229 se
.direct_byref
= 1;
7231 gfc_conv_expr_descriptor (&se
, expr
);
7232 gfc_add_block_to_block (&block
, &se
.pre
);
7233 gfc_add_block_to_block (&block
, &se
.post
);
7238 /* Scalar pointers. */
7239 se
.want_pointer
= 1;
7240 gfc_conv_expr (&se
, expr
);
7241 gfc_add_block_to_block (&block
, &se
.pre
);
7243 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7244 && expr
->symtree
->n
.sym
->attr
.dummy
)
7245 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7247 gfc_add_modify (&block
, dest
,
7248 fold_convert (TREE_TYPE (dest
), se
.expr
));
7249 gfc_add_block_to_block (&block
, &se
.post
);
7252 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7254 /* NULL initialization for CLASS components. */
7255 tmp
= gfc_trans_structure_assign (dest
,
7256 gfc_class_initializer (&cm
->ts
, expr
),
7258 gfc_add_expr_to_block (&block
, tmp
);
7260 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7261 && !cm
->attr
.proc_pointer
)
7263 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7264 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7265 else if (cm
->attr
.allocatable
)
7267 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7268 gfc_add_expr_to_block (&block
, tmp
);
7272 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7273 gfc_add_expr_to_block (&block
, tmp
);
7276 else if (cm
->ts
.type
== BT_CLASS
7277 && CLASS_DATA (cm
)->attr
.dimension
7278 && CLASS_DATA (cm
)->attr
.allocatable
7279 && expr
->ts
.type
== BT_DERIVED
)
7281 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7282 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7283 tmp
= gfc_class_vptr_get (dest
);
7284 gfc_add_modify (&block
, tmp
,
7285 fold_convert (TREE_TYPE (tmp
), vtab
));
7286 tmp
= gfc_class_data_get (dest
);
7287 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7288 gfc_add_expr_to_block (&block
, tmp
);
7290 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7292 /* NULL initialization for allocatable components. */
7293 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7294 null_pointer_node
));
7296 else if (init
&& (cm
->attr
.allocatable
7297 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7298 && expr
->ts
.type
!= BT_CLASS
)))
7300 /* Take care about non-array allocatable components here. The alloc_*
7301 routine below is motivated by the alloc_scalar_allocatable_for_
7302 assignment() routine, but with the realloc portions removed and
7304 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7309 /* The remainder of these instructions follow the if (cm->attr.pointer)
7310 if (!cm->attr.dimension) part above. */
7311 gfc_init_se (&se
, NULL
);
7312 gfc_conv_expr (&se
, expr
);
7313 gfc_add_block_to_block (&block
, &se
.pre
);
7315 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7316 && expr
->symtree
->n
.sym
->attr
.dummy
)
7317 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7319 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7321 tmp
= gfc_class_data_get (dest
);
7322 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7323 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7324 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7325 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7326 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7329 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7331 /* For deferred strings insert a memcpy. */
7332 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7335 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7336 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7338 : expr
->ts
.u
.cl
->backend_decl
);
7339 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7340 gfc_add_expr_to_block (&block
, tmp
);
7343 gfc_add_modify (&block
, tmp
,
7344 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7345 gfc_add_block_to_block (&block
, &se
.post
);
7347 else if (expr
->ts
.type
== BT_UNION
)
7350 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7351 /* We mark that the entire union should be initialized with a contrived
7352 EXPR_NULL expression at the beginning. */
7353 if (c
!= NULL
&& c
->n
.component
== NULL
7354 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7356 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7357 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7358 gfc_add_expr_to_block (&block
, tmp
);
7359 c
= gfc_constructor_next (c
);
7361 /* The following constructor expression, if any, represents a specific
7362 map intializer, as given by the user. */
7363 if (c
!= NULL
&& c
->expr
!= NULL
)
7365 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7366 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7367 gfc_add_expr_to_block (&block
, tmp
);
7370 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7372 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7374 tree dealloc
= NULL_TREE
;
7375 gfc_init_se (&se
, NULL
);
7376 gfc_conv_expr (&se
, expr
);
7377 gfc_add_block_to_block (&block
, &se
.pre
);
7378 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7379 expression in a temporary variable and deallocate the allocatable
7380 components. Then we can the copy the expression to the result. */
7381 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7382 && expr
->expr_type
!= EXPR_VARIABLE
)
7384 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7385 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7388 gfc_add_modify (&block
, dest
,
7389 fold_convert (TREE_TYPE (dest
), se
.expr
));
7390 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7391 && expr
->expr_type
!= EXPR_NULL
)
7393 // TODO: Fix caf_mode
7394 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7395 dest
, expr
->rank
, 0);
7396 gfc_add_expr_to_block (&block
, tmp
);
7397 if (dealloc
!= NULL_TREE
)
7398 gfc_add_expr_to_block (&block
, dealloc
);
7400 gfc_add_block_to_block (&block
, &se
.post
);
7404 /* Nested constructors. */
7405 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7406 gfc_add_expr_to_block (&block
, tmp
);
7409 else if (gfc_deferred_strlen (cm
, &tmp
))
7413 gcc_assert (strlen
);
7414 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7416 TREE_OPERAND (dest
, 0),
7419 if (expr
->expr_type
== EXPR_NULL
)
7421 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7422 gfc_add_modify (&block
, dest
, tmp
);
7423 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7424 gfc_add_modify (&block
, strlen
, tmp
);
7429 gfc_init_se (&se
, NULL
);
7430 gfc_conv_expr (&se
, expr
);
7431 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7432 tmp
= build_call_expr_loc (input_location
,
7433 builtin_decl_explicit (BUILT_IN_MALLOC
),
7435 gfc_add_modify (&block
, dest
,
7436 fold_convert (TREE_TYPE (dest
), tmp
));
7437 gfc_add_modify (&block
, strlen
, se
.string_length
);
7438 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7439 gfc_add_expr_to_block (&block
, tmp
);
7442 else if (!cm
->attr
.artificial
)
7444 /* Scalar component (excluding deferred parameters). */
7445 gfc_init_se (&se
, NULL
);
7446 gfc_init_se (&lse
, NULL
);
7448 gfc_conv_expr (&se
, expr
);
7449 if (cm
->ts
.type
== BT_CHARACTER
)
7450 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7452 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7453 gfc_add_expr_to_block (&block
, tmp
);
7455 return gfc_finish_block (&block
);
7458 /* Assign a derived type constructor to a variable. */
7461 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7470 gfc_start_block (&block
);
7471 cm
= expr
->ts
.u
.derived
->components
;
7473 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7474 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7475 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7479 gfc_init_se (&se
, NULL
);
7480 gfc_init_se (&lse
, NULL
);
7481 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7483 gfc_add_modify (&block
, lse
.expr
,
7484 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7486 return gfc_finish_block (&block
);
7490 gfc_init_se (&se
, NULL
);
7492 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7493 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7495 /* Skip absent members in default initializers. */
7496 if (!c
->expr
&& !cm
->attr
.allocatable
)
7499 /* Register the component with the caf-lib before it is initialized.
7500 Register only allocatable components, that are not coarray'ed
7501 components (%comp[*]). Only register when the constructor is not the
7503 if (coarray
&& !cm
->attr
.codimension
&& cm
->attr
.allocatable
7504 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7506 tree token
, desc
, size
;
7507 symbol_attribute attr
;
7508 bool is_array
= cm
->ts
.type
== BT_CLASS
7509 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7511 field
= cm
->backend_decl
;
7512 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7513 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7514 if (cm
->ts
.type
== BT_CLASS
)
7515 field
= gfc_class_data_get (field
);
7517 token
= is_array
? gfc_conv_descriptor_token (field
)
7518 : fold_build3_loc (input_location
, COMPONENT_REF
,
7519 TREE_TYPE (cm
->caf_token
), dest
,
7520 cm
->caf_token
, NULL_TREE
);
7524 /* The _caf_register routine looks at the rank of the array
7525 descriptor to decide whether the data registered is an array
7527 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7529 /* When the rank is not known just set a positive rank, which
7530 suffices to recognize the data as array. */
7533 size
= integer_zero_node
;
7535 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7536 build_int_cst (gfc_array_index_type
, rank
));
7540 desc
= gfc_conv_scalar_to_descriptor (&se
, field
, attr
);
7541 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7543 gfc_add_block_to_block (&block
, &se
.pre
);
7544 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7545 7, size
, build_int_cst (
7547 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7548 gfc_build_addr_expr (pvoid_type_node
,
7550 gfc_build_addr_expr (NULL_TREE
, desc
),
7551 null_pointer_node
, null_pointer_node
,
7553 gfc_add_expr_to_block (&block
, tmp
);
7555 field
= cm
->backend_decl
;
7556 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7557 dest
, field
, NULL_TREE
);
7560 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7561 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7566 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7567 expr
->ts
.u
.derived
, init
);
7568 gfc_add_expr_to_block (&block
, tmp
);
7570 return gfc_finish_block (&block
);
7574 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7575 gfc_component
*un
, gfc_expr
*init
)
7577 gfc_constructor
*ctor
;
7579 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7582 ctor
= gfc_constructor_first (init
->value
.constructor
);
7584 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7587 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7589 /* If we have an 'initialize all' constructor, do it first. */
7590 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7592 tree union_type
= TREE_TYPE (un
->backend_decl
);
7593 tree val
= build_constructor (union_type
, NULL
);
7594 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7595 ctor
= gfc_constructor_next (ctor
);
7598 /* Add the map initializer on top. */
7599 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7601 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7602 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7603 TREE_TYPE (un
->backend_decl
),
7604 un
->attr
.dimension
, un
->attr
.pointer
,
7605 un
->attr
.proc_pointer
);
7606 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7610 /* Build an expression for a constructor. If init is nonzero then
7611 this is part of a static variable initializer. */
7614 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7621 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7623 gcc_assert (se
->ss
== NULL
);
7624 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7625 type
= gfc_typenode_for_spec (&expr
->ts
);
7629 /* Create a temporary variable and fill it in. */
7630 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7631 /* The symtree in expr is NULL, if the code to generate is for
7632 initializing the static members only. */
7633 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7635 gfc_add_expr_to_block (&se
->pre
, tmp
);
7639 cm
= expr
->ts
.u
.derived
->components
;
7641 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7642 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7644 /* Skip absent members in default initializers and allocatable
7645 components. Although the latter have a default initializer
7646 of EXPR_NULL,... by default, the static nullify is not needed
7647 since this is done every time we come into scope. */
7648 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7651 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7652 && strcmp (cm
->name
, "_extends") == 0
7653 && cm
->initializer
->symtree
)
7657 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7658 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7659 vtab
= unshare_expr_without_location (vtab
);
7660 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7662 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7664 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7665 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7666 fold_convert (TREE_TYPE (cm
->backend_decl
),
7669 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7670 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7671 fold_convert (TREE_TYPE (cm
->backend_decl
),
7672 integer_zero_node
));
7673 else if (cm
->ts
.type
== BT_UNION
)
7674 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7677 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7678 TREE_TYPE (cm
->backend_decl
),
7679 cm
->attr
.dimension
, cm
->attr
.pointer
,
7680 cm
->attr
.proc_pointer
);
7681 val
= unshare_expr_without_location (val
);
7683 /* Append it to the constructor list. */
7684 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7688 se
->expr
= build_constructor (type
, v
);
7690 TREE_CONSTANT (se
->expr
) = 1;
7694 /* Translate a substring expression. */
7697 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7703 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7705 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7706 expr
->value
.character
.length
,
7707 expr
->value
.character
.string
);
7709 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7710 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7713 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7717 /* Entry point for expression translation. Evaluates a scalar quantity.
7718 EXPR is the expression to be translated, and SE is the state structure if
7719 called from within the scalarized. */
7722 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7727 if (ss
&& ss
->info
->expr
== expr
7728 && (ss
->info
->type
== GFC_SS_SCALAR
7729 || ss
->info
->type
== GFC_SS_REFERENCE
))
7731 gfc_ss_info
*ss_info
;
7734 /* Substitute a scalar expression evaluated outside the scalarization
7736 se
->expr
= ss_info
->data
.scalar
.value
;
7737 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7738 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7740 se
->string_length
= ss_info
->string_length
;
7741 gfc_advance_se_ss_chain (se
);
7745 /* We need to convert the expressions for the iso_c_binding derived types.
7746 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7747 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7748 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7749 updated to be an integer with a kind equal to the size of a (void *). */
7750 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7751 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7753 if (expr
->expr_type
== EXPR_VARIABLE
7754 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7755 || expr
->symtree
->n
.sym
->intmod_sym_id
7756 == ISOCBINDING_NULL_FUNPTR
))
7758 /* Set expr_type to EXPR_NULL, which will result in
7759 null_pointer_node being used below. */
7760 expr
->expr_type
= EXPR_NULL
;
7764 /* Update the type/kind of the expression to be what the new
7765 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7766 expr
->ts
.type
= BT_INTEGER
;
7767 expr
->ts
.f90_type
= BT_VOID
;
7768 expr
->ts
.kind
= gfc_index_integer_kind
;
7772 gfc_fix_class_refs (expr
);
7774 switch (expr
->expr_type
)
7777 gfc_conv_expr_op (se
, expr
);
7781 gfc_conv_function_expr (se
, expr
);
7785 gfc_conv_constant (se
, expr
);
7789 gfc_conv_variable (se
, expr
);
7793 se
->expr
= null_pointer_node
;
7796 case EXPR_SUBSTRING
:
7797 gfc_conv_substring_expr (se
, expr
);
7800 case EXPR_STRUCTURE
:
7801 gfc_conv_structure (se
, expr
, 0);
7805 gfc_conv_array_constructor_expr (se
, expr
);
7814 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7815 of an assignment. */
7817 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7819 gfc_conv_expr (se
, expr
);
7820 /* All numeric lvalues should have empty post chains. If not we need to
7821 figure out a way of rewriting an lvalue so that it has no post chain. */
7822 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7825 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7826 numeric expressions. Used for scalar values where inserting cleanup code
7829 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7833 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7834 gfc_conv_expr (se
, expr
);
7837 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7838 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7840 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7844 /* Helper to translate an expression and convert it to a particular type. */
7846 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7848 gfc_conv_expr_val (se
, expr
);
7849 se
->expr
= convert (type
, se
->expr
);
7853 /* Converts an expression so that it can be passed by reference. Scalar
7857 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7863 if (ss
&& ss
->info
->expr
== expr
7864 && ss
->info
->type
== GFC_SS_REFERENCE
)
7866 /* Returns a reference to the scalar evaluated outside the loop
7868 gfc_conv_expr (se
, expr
);
7870 if (expr
->ts
.type
== BT_CHARACTER
7871 && expr
->expr_type
!= EXPR_FUNCTION
)
7872 gfc_conv_string_parameter (se
);
7874 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7879 if (expr
->ts
.type
== BT_CHARACTER
)
7881 gfc_conv_expr (se
, expr
);
7882 gfc_conv_string_parameter (se
);
7886 if (expr
->expr_type
== EXPR_VARIABLE
)
7888 se
->want_pointer
= 1;
7889 gfc_conv_expr (se
, expr
);
7892 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7893 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7894 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7900 if (expr
->expr_type
== EXPR_FUNCTION
7901 && ((expr
->value
.function
.esym
7902 && expr
->value
.function
.esym
->result
->attr
.pointer
7903 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7904 || (!expr
->value
.function
.esym
&& !expr
->ref
7905 && expr
->symtree
->n
.sym
->attr
.pointer
7906 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7908 se
->want_pointer
= 1;
7909 gfc_conv_expr (se
, expr
);
7910 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7911 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7916 gfc_conv_expr (se
, expr
);
7918 /* Create a temporary var to hold the value. */
7919 if (TREE_CONSTANT (se
->expr
))
7921 tree tmp
= se
->expr
;
7922 STRIP_TYPE_NOPS (tmp
);
7923 var
= build_decl (input_location
,
7924 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7925 DECL_INITIAL (var
) = tmp
;
7926 TREE_STATIC (var
) = 1;
7931 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7932 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7934 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7936 /* Take the address of that value. */
7937 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7941 /* Get the _len component for an unlimited polymorphic expression. */
7944 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
7947 gfc_ref
*ref
= expr
->ref
;
7949 gfc_init_se (&se
, NULL
);
7950 while (ref
&& ref
->next
)
7952 gfc_add_len_component (expr
);
7953 gfc_conv_expr (&se
, expr
);
7954 gfc_add_block_to_block (block
, &se
.pre
);
7955 gcc_assert (se
.post
.head
== NULL_TREE
);
7958 gfc_free_ref_list (ref
->next
);
7963 gfc_free_ref_list (expr
->ref
);
7970 /* Assign _vptr and _len components as appropriate. BLOCK should be a
7971 statement-list outside of the scalarizer-loop. When code is generated, that
7972 depends on the scalarized expression, it is added to RSE.PRE.
7973 Returns le's _vptr tree and when set the len expressions in to_lenp and
7974 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
7978 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
7979 gfc_expr
* re
, gfc_se
*rse
,
7980 tree
* to_lenp
, tree
* from_lenp
)
7983 gfc_expr
* vptr_expr
;
7984 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
7985 bool set_vptr
= false, temp_rhs
= false;
7986 stmtblock_t
*pre
= block
;
7988 /* Create a temporary for complicated expressions. */
7989 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
7990 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
7992 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
7994 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
7999 /* Get the _vptr for the left-hand side expression. */
8000 gfc_init_se (&se
, NULL
);
8001 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8002 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8004 /* Care about _len for unlimited polymorphic entities. */
8005 if (UNLIMITED_POLY (vptr_expr
)
8006 || (vptr_expr
->ts
.type
== BT_DERIVED
8007 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8008 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8009 gfc_add_vptr_component (vptr_expr
);
8013 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8014 se
.want_pointer
= 1;
8015 gfc_conv_expr (&se
, vptr_expr
);
8016 gfc_free_expr (vptr_expr
);
8017 gfc_add_block_to_block (block
, &se
.pre
);
8018 gcc_assert (se
.post
.head
== NULL_TREE
);
8020 STRIP_NOPS (lhs_vptr
);
8022 /* Set the _vptr only when the left-hand side of the assignment is a
8026 /* Get the vptr from the rhs expression only, when it is variable.
8027 Functions are expected to be assigned to a temporary beforehand. */
8028 vptr_expr
= re
->expr_type
== EXPR_VARIABLE
8029 ? gfc_find_and_cut_at_last_class_ref (re
)
8031 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8033 if (to_len
!= NULL_TREE
)
8035 /* Get the _len information from the rhs. */
8036 if (UNLIMITED_POLY (vptr_expr
)
8037 || (vptr_expr
->ts
.type
== BT_DERIVED
8038 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8039 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8041 gfc_add_vptr_component (vptr_expr
);
8045 if (re
->expr_type
== EXPR_VARIABLE
8046 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8047 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8048 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8049 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8050 re
->symtree
->n
.sym
->backend_decl
))))
8053 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8054 re
->symtree
->n
.sym
->backend_decl
));
8056 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8057 re
->symtree
->n
.sym
->backend_decl
));
8059 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8062 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8064 else if (re
->expr_type
!= EXPR_NULL
)
8065 /* Only when rhs is non-NULL use its declared type for vptr
8067 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8069 /* When the rhs is NULL use the vtab of lhs' declared type. */
8070 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8075 gfc_init_se (&se
, NULL
);
8076 se
.want_pointer
= 1;
8077 gfc_conv_expr (&se
, vptr_expr
);
8078 gfc_free_expr (vptr_expr
);
8079 gfc_add_block_to_block (block
, &se
.pre
);
8080 gcc_assert (se
.post
.head
== NULL_TREE
);
8082 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8085 if (to_len
!= NULL_TREE
)
8087 /* The _len component needs to be set. Figure how to get the
8088 value of the right-hand side. */
8089 if (from_len
== NULL_TREE
)
8091 if (rse
->string_length
!= NULL_TREE
)
8092 from_len
= rse
->string_length
;
8093 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8095 from_len
= gfc_get_expr_charlen (re
);
8096 gfc_init_se (&se
, NULL
);
8097 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8098 gfc_add_block_to_block (block
, &se
.pre
);
8099 gcc_assert (se
.post
.head
== NULL_TREE
);
8100 from_len
= gfc_evaluate_now (se
.expr
, block
);
8103 from_len
= integer_zero_node
;
8105 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8110 /* Return the _len trees only, when requested. */
8114 *from_lenp
= from_len
;
8118 /* Indentify class valued proc_pointer assignments. */
8121 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8126 while (ref
&& ref
->next
)
8129 return ref
&& ref
->type
== REF_COMPONENT
8130 && ref
->u
.c
.component
->attr
.proc_pointer
8131 && expr2
->expr_type
== EXPR_VARIABLE
8132 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8137 gfc_trans_pointer_assign (gfc_code
* code
)
8139 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8143 /* Generate code for a pointer assignment. */
8146 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8154 bool scalar
, non_proc_pointer_assign
;
8157 gfc_start_block (&block
);
8159 gfc_init_se (&lse
, NULL
);
8161 /* Usually testing whether this is not a proc pointer assignment. */
8162 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8164 /* Check whether the expression is a scalar or not; we cannot use
8165 expr1->rank as it can be nonzero for proc pointers. */
8166 ss
= gfc_walk_expr (expr1
);
8167 scalar
= ss
== gfc_ss_terminator
;
8169 gfc_free_ss_chain (ss
);
8171 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8172 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8174 gfc_add_data_component (expr2
);
8175 /* The following is required as gfc_add_data_component doesn't
8176 update ts.type if there is a tailing REF_ARRAY. */
8177 expr2
->ts
.type
= BT_DERIVED
;
8182 /* Scalar pointers. */
8183 lse
.want_pointer
= 1;
8184 gfc_conv_expr (&lse
, expr1
);
8185 gfc_init_se (&rse
, NULL
);
8186 rse
.want_pointer
= 1;
8187 gfc_conv_expr (&rse
, expr2
);
8189 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8191 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8193 lse
.expr
= gfc_class_data_get (lse
.expr
);
8196 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8197 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8198 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8201 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8202 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8203 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8206 gfc_add_block_to_block (&block
, &lse
.pre
);
8207 gfc_add_block_to_block (&block
, &rse
.pre
);
8209 /* Check character lengths if character expression. The test is only
8210 really added if -fbounds-check is enabled. Exclude deferred
8211 character length lefthand sides. */
8212 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8213 && !expr1
->ts
.deferred
8214 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8215 && !gfc_is_proc_ptr_comp (expr1
))
8217 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8218 gcc_assert (lse
.string_length
&& rse
.string_length
);
8219 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8220 lse
.string_length
, rse
.string_length
,
8224 /* The assignment to an deferred character length sets the string
8225 length to that of the rhs. */
8226 if (expr1
->ts
.deferred
)
8228 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8229 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
8230 else if (lse
.string_length
!= NULL
)
8231 gfc_add_modify (&block
, lse
.string_length
,
8232 build_int_cst (gfc_charlen_type_node
, 0));
8235 gfc_add_modify (&block
, lse
.expr
,
8236 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8238 gfc_add_block_to_block (&block
, &rse
.post
);
8239 gfc_add_block_to_block (&block
, &lse
.post
);
8245 tree expr1_vptr
= NULL_TREE
;
8247 tree strlen_rhs
= NULL_TREE
;
8249 /* Array pointer. Find the last reference on the LHS and if it is an
8250 array section ref, we're dealing with bounds remapping. In this case,
8251 set it to AR_FULL so that gfc_conv_expr_descriptor does
8252 not see it and process the bounds remapping afterwards explicitly. */
8253 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8254 if (!remap
->next
&& remap
->type
== REF_ARRAY
8255 && remap
->u
.ar
.type
== AR_SECTION
)
8257 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8259 gfc_init_se (&lse
, NULL
);
8261 lse
.descriptor_only
= 1;
8262 gfc_conv_expr_descriptor (&lse
, expr1
);
8263 strlen_lhs
= lse
.string_length
;
8266 if (expr2
->expr_type
== EXPR_NULL
)
8268 /* Just set the data pointer to null. */
8269 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8271 else if (rank_remap
)
8273 /* If we are rank-remapping, just get the RHS's descriptor and
8274 process this later on. */
8275 gfc_init_se (&rse
, NULL
);
8276 rse
.direct_byref
= 1;
8277 rse
.byref_noassign
= 1;
8279 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8281 gfc_conv_function_expr (&rse
, expr2
);
8283 if (expr1
->ts
.type
!= BT_CLASS
)
8284 rse
.expr
= gfc_class_data_get (rse
.expr
);
8287 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8290 gfc_add_block_to_block (&block
, &rse
.pre
);
8291 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8292 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8294 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8295 fold_convert (TREE_TYPE (expr1_vptr
),
8296 gfc_class_vptr_get (tmp
)));
8297 rse
.expr
= gfc_class_data_get (tmp
);
8300 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8302 tree bound
[GFC_MAX_DIMENSIONS
];
8305 for (i
= 0; i
< expr2
->rank
; i
++)
8306 bound
[i
] = NULL_TREE
;
8307 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8308 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8310 GFC_ARRAY_POINTER_CONT
, false);
8311 tmp
= gfc_create_var (tmp
, "ptrtemp");
8312 rse
.descriptor_only
= 0;
8314 rse
.direct_byref
= 1;
8315 gfc_conv_expr_descriptor (&rse
, expr2
);
8316 strlen_rhs
= rse
.string_length
;
8321 gfc_conv_expr_descriptor (&rse
, expr2
);
8322 strlen_rhs
= rse
.string_length
;
8323 if (expr1
->ts
.type
== BT_CLASS
)
8324 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8329 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8331 /* Assign directly to the LHS's descriptor. */
8332 lse
.descriptor_only
= 0;
8333 lse
.direct_byref
= 1;
8334 gfc_conv_expr_descriptor (&lse
, expr2
);
8335 strlen_rhs
= lse
.string_length
;
8337 /* If this is a subreference array pointer assignment, use the rhs
8338 descriptor element size for the lhs span. */
8339 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
8341 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
8342 gfc_init_se (&rse
, NULL
);
8343 rse
.descriptor_only
= 1;
8344 gfc_conv_expr (&rse
, expr2
);
8345 if (expr1
->ts
.type
== BT_CLASS
)
8346 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8348 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
8349 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
8350 if (!INTEGER_CST_P (tmp
))
8351 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
8352 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
8354 else if (expr1
->ts
.type
== BT_CLASS
)
8356 rse
.expr
= NULL_TREE
;
8357 rse
.string_length
= NULL_TREE
;
8358 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8362 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8364 gfc_init_se (&rse
, NULL
);
8365 rse
.want_pointer
= 1;
8366 gfc_conv_function_expr (&rse
, expr2
);
8367 if (expr1
->ts
.type
!= BT_CLASS
)
8369 rse
.expr
= gfc_class_data_get (rse
.expr
);
8370 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8374 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8377 gfc_add_block_to_block (&block
, &rse
.pre
);
8378 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8379 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8381 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8382 fold_convert (TREE_TYPE (expr1_vptr
),
8383 gfc_class_vptr_get (tmp
)));
8384 rse
.expr
= gfc_class_data_get (tmp
);
8385 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8390 /* Assign to a temporary descriptor and then copy that
8391 temporary to the pointer. */
8392 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8393 lse
.descriptor_only
= 0;
8395 lse
.direct_byref
= 1;
8396 gfc_conv_expr_descriptor (&lse
, expr2
);
8397 strlen_rhs
= lse
.string_length
;
8398 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8401 gfc_add_block_to_block (&block
, &lse
.pre
);
8403 gfc_add_block_to_block (&block
, &rse
.pre
);
8405 /* If we do bounds remapping, update LHS descriptor accordingly. */
8409 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8413 /* Do rank remapping. We already have the RHS's descriptor
8414 converted in rse and now have to build the correct LHS
8415 descriptor for it. */
8419 tree lbound
, ubound
;
8422 dtype
= gfc_conv_descriptor_dtype (desc
);
8423 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8424 gfc_add_modify (&block
, dtype
, tmp
);
8426 /* Copy data pointer. */
8427 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8428 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8430 /* Copy offset but adjust it such that it would correspond
8431 to a lbound of zero. */
8432 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8433 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8435 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8437 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8439 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8440 gfc_array_index_type
, stride
, lbound
);
8441 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8442 gfc_array_index_type
, offs
, tmp
);
8444 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8446 /* Set the bounds as declared for the LHS and calculate strides as
8447 well as another offset update accordingly. */
8448 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8450 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8455 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8457 /* Convert declared bounds. */
8458 gfc_init_se (&lower_se
, NULL
);
8459 gfc_init_se (&upper_se
, NULL
);
8460 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8461 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8463 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8464 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8466 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8467 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8469 lbound
= gfc_evaluate_now (lbound
, &block
);
8470 ubound
= gfc_evaluate_now (ubound
, &block
);
8472 gfc_add_block_to_block (&block
, &lower_se
.post
);
8473 gfc_add_block_to_block (&block
, &upper_se
.post
);
8475 /* Set bounds in descriptor. */
8476 gfc_conv_descriptor_lbound_set (&block
, desc
,
8477 gfc_rank_cst
[dim
], lbound
);
8478 gfc_conv_descriptor_ubound_set (&block
, desc
,
8479 gfc_rank_cst
[dim
], ubound
);
8482 stride
= gfc_evaluate_now (stride
, &block
);
8483 gfc_conv_descriptor_stride_set (&block
, desc
,
8484 gfc_rank_cst
[dim
], stride
);
8486 /* Update offset. */
8487 offs
= gfc_conv_descriptor_offset_get (desc
);
8488 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8489 gfc_array_index_type
, lbound
, stride
);
8490 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8491 gfc_array_index_type
, offs
, tmp
);
8492 offs
= gfc_evaluate_now (offs
, &block
);
8493 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8495 /* Update stride. */
8496 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8497 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8498 gfc_array_index_type
, stride
, tmp
);
8503 /* Bounds remapping. Just shift the lower bounds. */
8505 gcc_assert (expr1
->rank
== expr2
->rank
);
8507 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8511 gcc_assert (remap
->u
.ar
.start
[dim
]);
8512 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8513 gfc_init_se (&lbound_se
, NULL
);
8514 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8516 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8517 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8518 dim
, lbound_se
.expr
);
8519 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8524 /* Check string lengths if applicable. The check is only really added
8525 to the output code if -fbounds-check is enabled. */
8526 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8528 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8529 gcc_assert (strlen_lhs
&& strlen_rhs
);
8530 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8531 strlen_lhs
, strlen_rhs
, &block
);
8534 /* If rank remapping was done, check with -fcheck=bounds that
8535 the target is at least as large as the pointer. */
8536 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8542 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8543 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8545 lsize
= gfc_evaluate_now (lsize
, &block
);
8546 rsize
= gfc_evaluate_now (rsize
, &block
);
8547 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8550 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8551 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8555 gfc_add_block_to_block (&block
, &lse
.post
);
8557 gfc_add_block_to_block (&block
, &rse
.post
);
8560 return gfc_finish_block (&block
);
8564 /* Makes sure se is suitable for passing as a function string parameter. */
8565 /* TODO: Need to check all callers of this function. It may be abused. */
8568 gfc_conv_string_parameter (gfc_se
* se
)
8572 if (TREE_CODE (se
->expr
) == STRING_CST
)
8574 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8575 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8579 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8581 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8583 type
= TREE_TYPE (se
->expr
);
8584 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8588 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8590 type
= build_pointer_type (type
);
8591 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8595 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8599 /* Generate code for assignment of scalar variables. Includes character
8600 strings and derived types with allocatable components.
8601 If you know that the LHS has no allocations, set dealloc to false.
8603 DEEP_COPY has no effect if the typespec TS is not a derived type with
8604 allocatable components. Otherwise, if it is set, an explicit copy of each
8605 allocatable component is made. This is necessary as a simple copy of the
8606 whole object would copy array descriptors as is, so that the lhs's
8607 allocatable components would point to the rhs's after the assignment.
8608 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8609 necessary if the rhs is a non-pointer function, as the allocatable components
8610 are not accessible by other means than the function's result after the
8611 function has returned. It is even more subtle when temporaries are involved,
8612 as the two following examples show:
8613 1. When we evaluate an array constructor, a temporary is created. Thus
8614 there is theoretically no alias possible. However, no deep copy is
8615 made for this temporary, so that if the constructor is made of one or
8616 more variable with allocatable components, those components still point
8617 to the variable's: DEEP_COPY should be set for the assignment from the
8618 temporary to the lhs in that case.
8619 2. When assigning a scalar to an array, we evaluate the scalar value out
8620 of the loop, store it into a temporary variable, and assign from that.
8621 In that case, deep copying when assigning to the temporary would be a
8622 waste of resources; however deep copies should happen when assigning from
8623 the temporary to each array element: again DEEP_COPY should be set for
8624 the assignment from the temporary to the lhs. */
8627 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8628 bool deep_copy
, bool dealloc
, bool in_coarray
)
8634 gfc_init_block (&block
);
8636 if (ts
.type
== BT_CHARACTER
)
8641 if (lse
->string_length
!= NULL_TREE
)
8643 gfc_conv_string_parameter (lse
);
8644 gfc_add_block_to_block (&block
, &lse
->pre
);
8645 llen
= lse
->string_length
;
8648 if (rse
->string_length
!= NULL_TREE
)
8650 gfc_conv_string_parameter (rse
);
8651 gfc_add_block_to_block (&block
, &rse
->pre
);
8652 rlen
= rse
->string_length
;
8655 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8656 rse
->expr
, ts
.kind
);
8658 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8660 tree tmp_var
= NULL_TREE
;
8663 /* Are the rhs and the lhs the same? */
8666 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8667 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8668 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8669 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8672 /* Deallocate the lhs allocated components as long as it is not
8673 the same as the rhs. This must be done following the assignment
8674 to prevent deallocating data that could be used in the rhs
8678 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8679 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8681 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8683 gfc_add_expr_to_block (&lse
->post
, tmp
);
8686 gfc_add_block_to_block (&block
, &rse
->pre
);
8687 gfc_add_block_to_block (&block
, &lse
->pre
);
8689 gfc_add_modify (&block
, lse
->expr
,
8690 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8692 /* Restore pointer address of coarray components. */
8693 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8695 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8696 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8698 gfc_add_expr_to_block (&block
, tmp
);
8701 /* Do a deep copy if the rhs is a variable, if it is not the
8705 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8706 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
8707 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
8709 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8711 gfc_add_expr_to_block (&block
, tmp
);
8714 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8716 gfc_add_block_to_block (&block
, &lse
->pre
);
8717 gfc_add_block_to_block (&block
, &rse
->pre
);
8718 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8719 TREE_TYPE (lse
->expr
), rse
->expr
);
8720 gfc_add_modify (&block
, lse
->expr
, tmp
);
8724 gfc_add_block_to_block (&block
, &lse
->pre
);
8725 gfc_add_block_to_block (&block
, &rse
->pre
);
8727 gfc_add_modify (&block
, lse
->expr
,
8728 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8731 gfc_add_block_to_block (&block
, &lse
->post
);
8732 gfc_add_block_to_block (&block
, &rse
->post
);
8734 return gfc_finish_block (&block
);
8738 /* There are quite a lot of restrictions on the optimisation in using an
8739 array function assign without a temporary. */
8742 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8745 bool seen_array_ref
;
8747 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8749 /* Play it safe with class functions assigned to a derived type. */
8750 if (gfc_is_alloc_class_array_function (expr2
)
8751 && expr1
->ts
.type
== BT_DERIVED
)
8754 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8755 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8758 /* Elemental functions are scalarized so that they don't need a
8759 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8760 they would need special treatment in gfc_trans_arrayfunc_assign. */
8761 if (expr2
->value
.function
.esym
!= NULL
8762 && expr2
->value
.function
.esym
->attr
.elemental
)
8765 /* Need a temporary if rhs is not FULL or a contiguous section. */
8766 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8769 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8770 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8773 /* Functions returning pointers or allocatables need temporaries. */
8774 c
= expr2
->value
.function
.esym
8775 ? (expr2
->value
.function
.esym
->attr
.pointer
8776 || expr2
->value
.function
.esym
->attr
.allocatable
)
8777 : (expr2
->symtree
->n
.sym
->attr
.pointer
8778 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8782 /* Character array functions need temporaries unless the
8783 character lengths are the same. */
8784 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8786 if (expr1
->ts
.u
.cl
->length
== NULL
8787 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8790 if (expr2
->ts
.u
.cl
->length
== NULL
8791 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8794 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8795 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8799 /* Check that no LHS component references appear during an array
8800 reference. This is needed because we do not have the means to
8801 span any arbitrary stride with an array descriptor. This check
8802 is not needed for the rhs because the function result has to be
8804 seen_array_ref
= false;
8805 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8807 if (ref
->type
== REF_ARRAY
)
8808 seen_array_ref
= true;
8809 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8813 /* Check for a dependency. */
8814 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8815 expr2
->value
.function
.esym
,
8816 expr2
->value
.function
.actual
,
8820 /* If we have reached here with an intrinsic function, we do not
8821 need a temporary except in the particular case that reallocation
8822 on assignment is active and the lhs is allocatable and a target. */
8823 if (expr2
->value
.function
.isym
)
8824 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8826 /* If the LHS is a dummy, we need a temporary if it is not
8828 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8831 /* If the lhs has been host_associated, is in common, a pointer or is
8832 a target and the function is not using a RESULT variable, aliasing
8833 can occur and a temporary is needed. */
8834 if ((sym
->attr
.host_assoc
8835 || sym
->attr
.in_common
8836 || sym
->attr
.pointer
8837 || sym
->attr
.cray_pointee
8838 || sym
->attr
.target
)
8839 && expr2
->symtree
!= NULL
8840 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8843 /* A PURE function can unconditionally be called without a temporary. */
8844 if (expr2
->value
.function
.esym
!= NULL
8845 && expr2
->value
.function
.esym
->attr
.pure
)
8848 /* Implicit_pure functions are those which could legally be declared
8850 if (expr2
->value
.function
.esym
!= NULL
8851 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8854 if (!sym
->attr
.use_assoc
8855 && !sym
->attr
.in_common
8856 && !sym
->attr
.pointer
8857 && !sym
->attr
.target
8858 && !sym
->attr
.cray_pointee
8859 && expr2
->value
.function
.esym
)
8861 /* A temporary is not needed if the function is not contained and
8862 the variable is local or host associated and not a pointer or
8864 if (!expr2
->value
.function
.esym
->attr
.contained
)
8867 /* A temporary is not needed if the lhs has never been host
8868 associated and the procedure is contained. */
8869 else if (!sym
->attr
.host_assoc
)
8872 /* A temporary is not needed if the variable is local and not
8873 a pointer, a target or a result. */
8875 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8879 /* Default to temporary use. */
8884 /* Provide the loop info so that the lhs descriptor can be built for
8885 reallocatable assignments from extrinsic function calls. */
8888 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8891 /* Signal that the function call should not be made by
8892 gfc_conv_loop_setup. */
8893 se
->ss
->is_alloc_lhs
= 1;
8894 gfc_init_loopinfo (loop
);
8895 gfc_add_ss_to_loop (loop
, *ss
);
8896 gfc_add_ss_to_loop (loop
, se
->ss
);
8897 gfc_conv_ss_startstride (loop
);
8898 gfc_conv_loop_setup (loop
, where
);
8899 gfc_copy_loopinfo_to_se (se
, loop
);
8900 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8901 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8902 se
->ss
->is_alloc_lhs
= 0;
8906 /* For assignment to a reallocatable lhs from intrinsic functions,
8907 replace the se.expr (ie. the result) with a temporary descriptor.
8908 Null the data field so that the library allocates space for the
8909 result. Free the data of the original descriptor after the function,
8910 in case it appears in an argument expression and transfer the
8911 result to the original descriptor. */
8914 fcncall_realloc_result (gfc_se
*se
, int rank
)
8923 /* Use the allocation done by the library. Substitute the lhs
8924 descriptor with a copy, whose data field is nulled.*/
8925 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8926 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8927 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8929 /* Unallocated, the descriptor does not have a dtype. */
8930 tmp
= gfc_conv_descriptor_dtype (desc
);
8931 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8933 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8934 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8935 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8937 /* Free the lhs after the function call and copy the result data to
8938 the lhs descriptor. */
8939 tmp
= gfc_conv_descriptor_data_get (desc
);
8940 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8941 boolean_type_node
, tmp
,
8942 build_int_cst (TREE_TYPE (tmp
), 0));
8943 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8944 tmp
= gfc_call_free (tmp
);
8945 gfc_add_expr_to_block (&se
->post
, tmp
);
8947 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8948 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8950 /* Check that the shapes are the same between lhs and expression. */
8951 for (n
= 0 ; n
< rank
; n
++)
8954 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8955 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8956 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8957 gfc_array_index_type
, tmp
, tmp1
);
8958 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8959 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8960 gfc_array_index_type
, tmp
, tmp1
);
8961 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8962 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8963 gfc_array_index_type
, tmp
, tmp1
);
8964 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8965 boolean_type_node
, tmp
,
8966 gfc_index_zero_node
);
8967 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8968 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8969 boolean_type_node
, tmp
,
8973 /* 'zero_cond' being true is equal to lhs not being allocated or the
8974 shapes being different. */
8975 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8977 /* Now reset the bounds returned from the function call to bounds based
8978 on the lhs lbounds, except where the lhs is not allocated or the shapes
8979 of 'variable and 'expr' are different. Set the offset accordingly. */
8980 offset
= gfc_index_zero_node
;
8981 for (n
= 0 ; n
< rank
; n
++)
8985 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8986 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8987 gfc_array_index_type
, zero_cond
,
8988 gfc_index_one_node
, lbound
);
8989 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8991 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8992 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8993 gfc_array_index_type
, tmp
, lbound
);
8994 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8995 gfc_rank_cst
[n
], lbound
);
8996 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8997 gfc_rank_cst
[n
], tmp
);
8999 /* Set stride and accumulate the offset. */
9000 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9001 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9002 gfc_rank_cst
[n
], tmp
);
9003 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9004 gfc_array_index_type
, lbound
, tmp
);
9005 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9006 gfc_array_index_type
, offset
, tmp
);
9007 offset
= gfc_evaluate_now (offset
, &se
->post
);
9010 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9015 /* Try to translate array(:) = func (...), where func is a transformational
9016 array function, without using a temporary. Returns NULL if this isn't the
9020 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9024 gfc_component
*comp
= NULL
;
9027 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9030 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9032 comp
= gfc_get_proc_ptr_comp (expr2
);
9033 gcc_assert (expr2
->value
.function
.isym
9034 || (comp
&& comp
->attr
.dimension
)
9035 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9036 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
9038 gfc_init_se (&se
, NULL
);
9039 gfc_start_block (&se
.pre
);
9040 se
.want_pointer
= 1;
9042 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9044 if (expr1
->ts
.type
== BT_DERIVED
9045 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9048 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9050 gfc_add_expr_to_block (&se
.pre
, tmp
);
9053 se
.direct_byref
= 1;
9054 se
.ss
= gfc_walk_expr (expr2
);
9055 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9057 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9058 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9059 Clearly, this cannot be done for an allocatable function result, since
9060 the shape of the result is unknown and, in any case, the function must
9061 correctly take care of the reallocation internally. For intrinsic
9062 calls, the array data is freed and the library takes care of allocation.
9063 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9065 if (flag_realloc_lhs
9066 && gfc_is_reallocatable_lhs (expr1
)
9067 && !gfc_expr_attr (expr1
).codimension
9068 && !gfc_is_coindexed (expr1
)
9069 && !(expr2
->value
.function
.esym
9070 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9072 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9074 if (!expr2
->value
.function
.isym
)
9076 ss
= gfc_walk_expr (expr1
);
9077 gcc_assert (ss
!= gfc_ss_terminator
);
9079 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9080 ss
->is_alloc_lhs
= 1;
9083 fcncall_realloc_result (&se
, expr1
->rank
);
9086 gfc_conv_function_expr (&se
, expr2
);
9087 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9090 gfc_cleanup_loop (&loop
);
9092 gfc_free_ss_chain (se
.ss
);
9094 return gfc_finish_block (&se
.pre
);
9098 /* Try to efficiently translate array(:) = 0. Return NULL if this
9102 gfc_trans_zero_assign (gfc_expr
* expr
)
9104 tree dest
, len
, type
;
9108 sym
= expr
->symtree
->n
.sym
;
9109 dest
= gfc_get_symbol_decl (sym
);
9111 type
= TREE_TYPE (dest
);
9112 if (POINTER_TYPE_P (type
))
9113 type
= TREE_TYPE (type
);
9114 if (!GFC_ARRAY_TYPE_P (type
))
9117 /* Determine the length of the array. */
9118 len
= GFC_TYPE_ARRAY_SIZE (type
);
9119 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9122 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9123 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9124 fold_convert (gfc_array_index_type
, tmp
));
9126 /* If we are zeroing a local array avoid taking its address by emitting
9128 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9129 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9130 dest
, build_constructor (TREE_TYPE (dest
),
9133 /* Convert arguments to the correct types. */
9134 dest
= fold_convert (pvoid_type_node
, dest
);
9135 len
= fold_convert (size_type_node
, len
);
9137 /* Construct call to __builtin_memset. */
9138 tmp
= build_call_expr_loc (input_location
,
9139 builtin_decl_explicit (BUILT_IN_MEMSET
),
9140 3, dest
, integer_zero_node
, len
);
9141 return fold_convert (void_type_node
, tmp
);
9145 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9146 that constructs the call to __builtin_memcpy. */
9149 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9153 /* Convert arguments to the correct types. */
9154 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9155 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9157 dst
= fold_convert (pvoid_type_node
, dst
);
9159 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9160 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9162 src
= fold_convert (pvoid_type_node
, src
);
9164 len
= fold_convert (size_type_node
, len
);
9166 /* Construct call to __builtin_memcpy. */
9167 tmp
= build_call_expr_loc (input_location
,
9168 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9170 return fold_convert (void_type_node
, tmp
);
9174 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9175 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9176 source/rhs, both are gfc_full_array_ref_p which have been checked for
9180 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9182 tree dst
, dlen
, dtype
;
9183 tree src
, slen
, stype
;
9186 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9187 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9189 dtype
= TREE_TYPE (dst
);
9190 if (POINTER_TYPE_P (dtype
))
9191 dtype
= TREE_TYPE (dtype
);
9192 stype
= TREE_TYPE (src
);
9193 if (POINTER_TYPE_P (stype
))
9194 stype
= TREE_TYPE (stype
);
9196 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9199 /* Determine the lengths of the arrays. */
9200 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9201 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9203 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9204 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9205 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9207 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9208 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9210 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9211 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9212 slen
, fold_convert (gfc_array_index_type
, tmp
));
9214 /* Sanity check that they are the same. This should always be
9215 the case, as we should already have checked for conformance. */
9216 if (!tree_int_cst_equal (slen
, dlen
))
9219 return gfc_build_memcpy_call (dst
, src
, dlen
);
9223 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9224 this can't be done. EXPR1 is the destination/lhs for which
9225 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9228 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9230 unsigned HOST_WIDE_INT nelem
;
9236 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9240 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9241 dtype
= TREE_TYPE (dst
);
9242 if (POINTER_TYPE_P (dtype
))
9243 dtype
= TREE_TYPE (dtype
);
9244 if (!GFC_ARRAY_TYPE_P (dtype
))
9247 /* Determine the lengths of the array. */
9248 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9249 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9252 /* Confirm that the constructor is the same size. */
9253 if (compare_tree_int (len
, nelem
) != 0)
9256 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9257 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9258 fold_convert (gfc_array_index_type
, tmp
));
9260 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9261 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9263 stype
= TREE_TYPE (src
);
9264 if (POINTER_TYPE_P (stype
))
9265 stype
= TREE_TYPE (stype
);
9267 return gfc_build_memcpy_call (dst
, src
, len
);
9271 /* Tells whether the expression is to be treated as a variable reference. */
9274 gfc_expr_is_variable (gfc_expr
*expr
)
9277 gfc_component
*comp
;
9278 gfc_symbol
*func_ifc
;
9280 if (expr
->expr_type
== EXPR_VARIABLE
)
9283 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9286 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9287 return gfc_expr_is_variable (arg
);
9290 /* A data-pointer-returning function should be considered as a variable
9292 if (expr
->expr_type
== EXPR_FUNCTION
9293 && expr
->ref
== NULL
)
9295 if (expr
->value
.function
.isym
!= NULL
)
9298 if (expr
->value
.function
.esym
!= NULL
)
9300 func_ifc
= expr
->value
.function
.esym
;
9305 gcc_assert (expr
->symtree
);
9306 func_ifc
= expr
->symtree
->n
.sym
;
9313 comp
= gfc_get_proc_ptr_comp (expr
);
9314 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9317 func_ifc
= comp
->ts
.interface
;
9321 if (expr
->expr_type
== EXPR_COMPCALL
)
9323 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9324 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9331 gcc_assert (func_ifc
->attr
.function
9332 && func_ifc
->result
!= NULL
);
9333 return func_ifc
->result
->attr
.pointer
;
9337 /* Is the lhs OK for automatic reallocation? */
9340 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9344 /* An allocatable variable with no reference. */
9345 if (expr
->symtree
->n
.sym
->attr
.allocatable
9349 /* All that can be left are allocatable components. However, we do
9350 not check for allocatable components here because the expression
9351 could be an allocatable component of a pointer component. */
9352 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9353 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9356 /* Find an allocatable component ref last. */
9357 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9358 if (ref
->type
== REF_COMPONENT
9360 && ref
->u
.c
.component
->attr
.allocatable
)
9367 /* Allocate or reallocate scalar lhs, as necessary. */
9370 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9385 if (!expr1
|| expr1
->rank
)
9388 if (!expr2
|| expr2
->rank
)
9391 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9392 if (ref
->type
== REF_SUBSTRING
)
9395 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9397 /* Since this is a scalar lhs, we can afford to do this. That is,
9398 there is no risk of side effects being repeated. */
9399 gfc_init_se (&lse
, NULL
);
9400 lse
.want_pointer
= 1;
9401 gfc_conv_expr (&lse
, expr1
);
9403 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9404 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9406 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9407 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9408 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9410 tmp
= build3_v (COND_EXPR
, cond
,
9411 build1_v (GOTO_EXPR
, jump_label1
),
9412 build_empty_stmt (input_location
));
9413 gfc_add_expr_to_block (block
, tmp
);
9415 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9417 /* Use the rhs string length and the lhs element size. */
9418 size
= string_length
;
9419 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9420 tmp
= TYPE_SIZE_UNIT (tmp
);
9421 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9422 TREE_TYPE (tmp
), tmp
,
9423 fold_convert (TREE_TYPE (tmp
), size
));
9427 /* Otherwise use the length in bytes of the rhs. */
9428 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9429 size_in_bytes
= size
;
9432 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9433 size_in_bytes
, size_one_node
);
9435 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9437 tree caf_decl
, token
;
9439 symbol_attribute attr
;
9441 gfc_clear_attr (&attr
);
9442 gfc_init_se (&caf_se
, NULL
);
9444 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9445 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9447 gfc_add_block_to_block (block
, &caf_se
.pre
);
9448 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9449 gfc_build_addr_expr (NULL_TREE
, token
),
9450 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9453 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9455 tmp
= build_call_expr_loc (input_location
,
9456 builtin_decl_explicit (BUILT_IN_CALLOC
),
9457 2, build_one_cst (size_type_node
),
9459 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9460 gfc_add_modify (block
, lse
.expr
, tmp
);
9464 tmp
= build_call_expr_loc (input_location
,
9465 builtin_decl_explicit (BUILT_IN_MALLOC
),
9467 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9468 gfc_add_modify (block
, lse
.expr
, tmp
);
9471 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9473 /* Deferred characters need checking for lhs and rhs string
9474 length. Other deferred parameter variables will have to
9476 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9477 gfc_add_expr_to_block (block
, tmp
);
9479 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9480 gfc_add_expr_to_block (block
, tmp
);
9482 /* For a deferred length character, reallocate if lengths of lhs and
9483 rhs are different. */
9484 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9486 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9487 lse
.string_length
, size
);
9488 /* Jump past the realloc if the lengths are the same. */
9489 tmp
= build3_v (COND_EXPR
, cond
,
9490 build1_v (GOTO_EXPR
, jump_label2
),
9491 build_empty_stmt (input_location
));
9492 gfc_add_expr_to_block (block
, tmp
);
9493 tmp
= build_call_expr_loc (input_location
,
9494 builtin_decl_explicit (BUILT_IN_REALLOC
),
9495 2, fold_convert (pvoid_type_node
, lse
.expr
),
9497 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9498 gfc_add_modify (block
, lse
.expr
, tmp
);
9499 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9500 gfc_add_expr_to_block (block
, tmp
);
9502 /* Update the lhs character length. */
9503 size
= string_length
;
9504 gfc_add_modify (block
, lse
.string_length
, size
);
9508 /* Check for assignments of the type
9512 to make sure we do not check for reallocation unneccessarily. */
9516 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9518 gfc_actual_arglist
*a
;
9521 switch (expr2
->expr_type
)
9524 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9527 if (expr2
->value
.function
.esym
9528 && expr2
->value
.function
.esym
->attr
.elemental
)
9530 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9533 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9538 else if (expr2
->value
.function
.isym
9539 && expr2
->value
.function
.isym
->elemental
)
9541 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9544 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9553 switch (expr2
->value
.op
.op
)
9556 case INTRINSIC_UPLUS
:
9557 case INTRINSIC_UMINUS
:
9558 case INTRINSIC_PARENTHESES
:
9559 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9561 case INTRINSIC_PLUS
:
9562 case INTRINSIC_MINUS
:
9563 case INTRINSIC_TIMES
:
9564 case INTRINSIC_DIVIDE
:
9565 case INTRINSIC_POWER
:
9569 case INTRINSIC_NEQV
:
9576 case INTRINSIC_EQ_OS
:
9577 case INTRINSIC_NE_OS
:
9578 case INTRINSIC_GT_OS
:
9579 case INTRINSIC_GE_OS
:
9580 case INTRINSIC_LT_OS
:
9581 case INTRINSIC_LE_OS
:
9583 e1
= expr2
->value
.op
.op1
;
9584 e2
= expr2
->value
.op
.op2
;
9586 if (e1
->rank
== 0 && e2
->rank
> 0)
9587 return is_runtime_conformable (expr1
, e2
);
9588 else if (e1
->rank
> 0 && e2
->rank
== 0)
9589 return is_runtime_conformable (expr1
, e1
);
9590 else if (e1
->rank
> 0 && e2
->rank
> 0)
9591 return is_runtime_conformable (expr1
, e1
)
9592 && is_runtime_conformable (expr1
, e2
);
9610 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9611 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
)
9615 tree stdcopy
, to_len
, from_len
;
9616 vec
<tree
, va_gc
> *args
= NULL
;
9618 tmp
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9621 fcn
= gfc_vptr_copy_get (tmp
);
9623 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9624 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9627 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9628 || INDIRECT_REF_P (tmp
)
9629 || (rhs
->ts
.type
== BT_DERIVED
9630 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9631 && !rhs
->ts
.u
.derived
->attr
.pointer
9632 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9633 || (UNLIMITED_POLY (rhs
)
9634 && !CLASS_DATA (rhs
)->attr
.pointer
9635 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9636 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9638 vec_safe_push (args
, tmp
);
9639 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9640 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9641 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9642 || INDIRECT_REF_P (tmp
)
9643 || (lhs
->ts
.type
== BT_DERIVED
9644 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9645 && !lhs
->ts
.u
.derived
->attr
.pointer
9646 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9647 || (UNLIMITED_POLY (lhs
)
9648 && !CLASS_DATA (lhs
)->attr
.pointer
9649 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9650 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9652 vec_safe_push (args
, tmp
);
9654 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9656 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9659 vec_safe_push (args
, from_len
);
9660 vec_safe_push (args
, to_len
);
9661 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9663 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9664 boolean_type_node
, from_len
,
9666 return fold_build3_loc (input_location
, COND_EXPR
,
9667 void_type_node
, tmp
,
9675 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9676 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9678 gfc_init_block (&tblock
);
9679 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9680 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9681 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9682 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9683 /* When coming from a ptr_copy lhs and rhs are swapped. */
9684 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9685 fold_convert (TREE_TYPE (rhst
), tmp
));
9686 return gfc_finish_block (&tblock
);
9690 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9691 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9692 init_flag indicates initialization expressions and dealloc that no
9693 deallocate prior assignment is needed (if in doubt, set true).
9694 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9695 routine instead of a pointer assignment. Alias resolution is only done,
9696 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9697 where it is known, that newly allocated memory on the lhs can never be
9698 an alias of the rhs. */
9701 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9702 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9707 gfc_ss
*lss_section
;
9714 bool scalar_to_array
;
9717 bool maybe_workshare
= false;
9718 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9719 bool is_poly_assign
;
9721 /* Assignment of the form lhs = rhs. */
9722 gfc_start_block (&block
);
9724 gfc_init_se (&lse
, NULL
);
9725 gfc_init_se (&rse
, NULL
);
9728 lss
= gfc_walk_expr (expr1
);
9729 if (gfc_is_reallocatable_lhs (expr1
)
9730 && !(expr2
->expr_type
== EXPR_FUNCTION
9731 && expr2
->value
.function
.isym
!= NULL
))
9732 lss
->is_alloc_lhs
= 1;
9735 if ((expr1
->ts
.type
== BT_DERIVED
)
9736 && (gfc_is_alloc_class_array_function (expr2
)
9737 || gfc_is_alloc_class_scalar_function (expr2
)))
9738 expr2
->must_finalize
= 1;
9740 /* Checking whether a class assignment is desired is quite complicated and
9741 needed at two locations, so do it once only before the information is
9743 lhs_attr
= gfc_expr_attr (expr1
);
9744 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
9745 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9746 && (expr1
->ts
.type
== BT_CLASS
9747 || gfc_is_class_array_ref (expr1
, NULL
)
9748 || gfc_is_class_scalar_expr (expr1
)
9749 || gfc_is_class_array_ref (expr2
, NULL
)
9750 || gfc_is_class_scalar_expr (expr2
));
9753 /* Only analyze the expressions for coarray properties, when in coarray-lib
9755 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9757 lhs_caf_attr
= gfc_caf_attr (expr1
);
9758 rhs_caf_attr
= gfc_caf_attr (expr2
);
9761 if (lss
!= gfc_ss_terminator
)
9763 /* The assignment needs scalarization. */
9766 /* Find a non-scalar SS from the lhs. */
9767 while (lss_section
!= gfc_ss_terminator
9768 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9769 lss_section
= lss_section
->next
;
9771 gcc_assert (lss_section
!= gfc_ss_terminator
);
9773 /* Initialize the scalarizer. */
9774 gfc_init_loopinfo (&loop
);
9777 rss
= gfc_walk_expr (expr2
);
9778 if (rss
== gfc_ss_terminator
)
9779 /* The rhs is scalar. Add a ss for the expression. */
9780 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9781 /* When doing a class assign, then the handle to the rhs needs to be a
9782 pointer to allow for polymorphism. */
9783 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
9784 rss
->info
->type
= GFC_SS_REFERENCE
;
9786 /* Associate the SS with the loop. */
9787 gfc_add_ss_to_loop (&loop
, lss
);
9788 gfc_add_ss_to_loop (&loop
, rss
);
9790 /* Calculate the bounds of the scalarization. */
9791 gfc_conv_ss_startstride (&loop
);
9792 /* Enable loop reversal. */
9793 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9794 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9795 /* Resolve any data dependencies in the statement. */
9797 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9798 /* Setup the scalarizing loops. */
9799 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9801 /* Setup the gfc_se structures. */
9802 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9803 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9806 gfc_mark_ss_chain_used (rss
, 1);
9807 if (loop
.temp_ss
== NULL
)
9810 gfc_mark_ss_chain_used (lss
, 1);
9814 lse
.ss
= loop
.temp_ss
;
9815 gfc_mark_ss_chain_used (lss
, 3);
9816 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9819 /* Allow the scalarizer to workshare array assignments. */
9820 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
9821 == OMPWS_WORKSHARE_FLAG
9822 && loop
.temp_ss
== NULL
)
9824 maybe_workshare
= true;
9825 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
9828 /* Start the scalarized loop body. */
9829 gfc_start_scalarized_body (&loop
, &body
);
9832 gfc_init_block (&body
);
9834 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9836 /* Translate the expression. */
9837 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
9838 && lhs_caf_attr
.codimension
;
9839 gfc_conv_expr (&rse
, expr2
);
9841 /* Deal with the case of a scalar class function assigned to a derived type. */
9842 if (gfc_is_alloc_class_scalar_function (expr2
)
9843 && expr1
->ts
.type
== BT_DERIVED
)
9845 rse
.expr
= gfc_class_data_get (rse
.expr
);
9846 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9849 /* Stabilize a string length for temporaries. */
9850 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
9851 && !(VAR_P (rse
.string_length
)
9852 || TREE_CODE (rse
.string_length
) == PARM_DECL
9853 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
9854 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9855 else if (expr2
->ts
.type
== BT_CHARACTER
)
9856 string_length
= rse
.string_length
;
9858 string_length
= NULL_TREE
;
9862 gfc_conv_tmp_array_ref (&lse
);
9863 if (expr2
->ts
.type
== BT_CHARACTER
)
9864 lse
.string_length
= string_length
;
9868 gfc_conv_expr (&lse
, expr1
);
9869 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
9871 && gfc_expr_attr (expr1
).allocatable
9878 /* We should only get array references here. */
9879 gcc_assert (TREE_CODE (lse
.expr
) == POINTER_PLUS_EXPR
9880 || TREE_CODE (lse
.expr
) == ARRAY_REF
);
9882 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
9883 or the array itself(ARRAY_REF). */
9884 tmp
= TREE_OPERAND (lse
.expr
, 0);
9886 /* Provide the address of the array. */
9887 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
9888 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9890 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9891 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9892 msg
= _("Assignment of scalar to unallocated array");
9893 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
9894 &expr1
->where
, msg
);
9898 /* Assignments of scalar derived types with allocatable components
9899 to arrays must be done with a deep copy and the rhs temporary
9900 must have its components deallocated afterwards. */
9901 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9902 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9903 && !gfc_expr_is_variable (expr2
)
9904 && expr1
->rank
&& !expr2
->rank
);
9905 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9907 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9908 && gfc_is_alloc_class_scalar_function (expr2
));
9909 if (scalar_to_array
&& dealloc
)
9911 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9912 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9915 /* When assigning a character function result to a deferred-length variable,
9916 the function call must happen before the (re)allocation of the lhs -
9917 otherwise the character length of the result is not known.
9918 NOTE: This relies on having the exact dependence of the length type
9919 parameter available to the caller; gfortran saves it in the .mod files.
9920 NOTE ALSO: The concatenation operation generates a temporary pointer,
9921 whose allocation must go to the innermost loop. */
9922 if (flag_realloc_lhs
9923 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
9924 && !(lss
!= gfc_ss_terminator
9925 && expr2
->expr_type
== EXPR_OP
9926 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))
9927 gfc_add_block_to_block (&block
, &rse
.pre
);
9929 /* Nullify the allocatable components corresponding to those of the lhs
9930 derived type, so that the finalization of the function result does not
9931 affect the lhs of the assignment. Prepend is used to ensure that the
9932 nullification occurs before the call to the finalizer. In the case of
9933 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9934 as part of the deep copy. */
9935 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
9936 && (gfc_is_alloc_class_array_function (expr2
)
9937 || gfc_is_alloc_class_scalar_function (expr2
)))
9940 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9941 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9942 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9943 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9948 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
9949 use_vptr_copy
|| (lhs_attr
.allocatable
9950 && !lhs_attr
.dimension
));
9951 /* Modify the expr1 after the assignment, to allow the realloc below.
9952 Therefore only needed, when realloc_lhs is enabled. */
9953 if (flag_realloc_lhs
&& !lhs_attr
.pointer
)
9954 gfc_add_data_component (expr1
);
9956 else if (flag_coarray
== GFC_FCOARRAY_LIB
9957 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
9958 && lhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.alloc_comp
)
9961 gfc_actual_arglist a1
, a2
;
9966 code
.ext
.actual
= &a1
;
9967 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9968 tmp
= gfc_conv_intrinsic_subroutine (&code
);
9971 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9972 gfc_expr_is_variable (expr2
)
9974 || expr2
->expr_type
== EXPR_ARRAY
,
9975 !(l_is_temp
|| init_flag
) && dealloc
,
9976 expr1
->symtree
->n
.sym
->attr
.codimension
);
9977 /* Add the pre blocks to the body. */
9978 gfc_add_block_to_block (&body
, &rse
.pre
);
9979 gfc_add_block_to_block (&body
, &lse
.pre
);
9980 gfc_add_expr_to_block (&body
, tmp
);
9981 /* Add the post blocks to the body. */
9982 gfc_add_block_to_block (&body
, &rse
.post
);
9983 gfc_add_block_to_block (&body
, &lse
.post
);
9985 if (lss
== gfc_ss_terminator
)
9987 /* F2003: Add the code for reallocation on assignment. */
9988 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9989 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9992 /* Use the scalar assignment as is. */
9993 gfc_add_block_to_block (&block
, &body
);
9997 gcc_assert (lse
.ss
== gfc_ss_terminator
9998 && rse
.ss
== gfc_ss_terminator
);
10002 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10004 /* We need to copy the temporary to the actual lhs. */
10005 gfc_init_se (&lse
, NULL
);
10006 gfc_init_se (&rse
, NULL
);
10007 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10008 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10010 rse
.ss
= loop
.temp_ss
;
10013 gfc_conv_tmp_array_ref (&rse
);
10014 gfc_conv_expr (&lse
, expr1
);
10016 gcc_assert (lse
.ss
== gfc_ss_terminator
10017 && rse
.ss
== gfc_ss_terminator
);
10019 if (expr2
->ts
.type
== BT_CHARACTER
)
10020 rse
.string_length
= string_length
;
10022 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10024 gfc_add_expr_to_block (&body
, tmp
);
10027 /* F2003: Allocate or reallocate lhs of allocatable array. */
10028 if (flag_realloc_lhs
10029 && gfc_is_reallocatable_lhs (expr1
)
10031 && !is_runtime_conformable (expr1
, expr2
))
10033 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10034 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10035 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10036 if (tmp
!= NULL_TREE
)
10037 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10040 if (maybe_workshare
)
10041 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10043 /* Generate the copying loops. */
10044 gfc_trans_scalarizing_loops (&loop
, &body
);
10046 /* Wrap the whole thing up. */
10047 gfc_add_block_to_block (&block
, &loop
.pre
);
10048 gfc_add_block_to_block (&block
, &loop
.post
);
10050 gfc_cleanup_loop (&loop
);
10053 return gfc_finish_block (&block
);
10057 /* Check whether EXPR is a copyable array. */
10060 copyable_array_p (gfc_expr
* expr
)
10062 if (expr
->expr_type
!= EXPR_VARIABLE
)
10065 /* First check it's an array. */
10066 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10069 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10072 /* Next check that it's of a simple enough type. */
10073 switch (expr
->ts
.type
)
10085 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10094 /* Translate an assignment. */
10097 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10098 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10102 /* Special case a single function returning an array. */
10103 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10105 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10110 /* Special case assigning an array to zero. */
10111 if (copyable_array_p (expr1
)
10112 && is_zero_initializer_p (expr2
))
10114 tmp
= gfc_trans_zero_assign (expr1
);
10119 /* Special case copying one array to another. */
10120 if (copyable_array_p (expr1
)
10121 && copyable_array_p (expr2
)
10122 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10123 && !gfc_check_dependency (expr1
, expr2
, 0))
10125 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10130 /* Special case initializing an array from a constant array constructor. */
10131 if (copyable_array_p (expr1
)
10132 && expr2
->expr_type
== EXPR_ARRAY
10133 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10135 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10140 /* Fallback to the scalarizer to generate explicit loops. */
10141 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10142 use_vptr_copy
, may_alias
);
10146 gfc_trans_init_assign (gfc_code
* code
)
10148 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10152 gfc_trans_assign (gfc_code
* code
)
10154 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);