1 /* Expression translation
2 Copyright (C) 2002-2017 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 logical_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 logical_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 logical_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
, logical_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 logical_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
, logical_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
, logical_type_node
, tmp
,
1703 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1704 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1705 logical_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 /* Make sure the backend_decl is present before accessing it. */
1842 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1843 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1844 : expr
->symtree
->n
.sym
->backend_decl
;
1846 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1848 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1850 caf_decl
= gfc_class_data_get (caf_decl
);
1851 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1854 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1856 if (ref
->type
== REF_COMPONENT
1857 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1859 caf_decl
= gfc_class_data_get (caf_decl
);
1860 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1864 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1868 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1871 /* The following code assumes that the coarray is a component reachable via
1872 only scalar components/variables; the Fortran standard guarantees this. */
1874 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1875 if (ref
->type
== REF_COMPONENT
)
1877 gfc_component
*comp
= ref
->u
.c
.component
;
1879 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1880 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1881 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1882 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1883 comp
->backend_decl
, NULL_TREE
);
1884 if (comp
->ts
.type
== BT_CLASS
)
1886 caf_decl
= gfc_class_data_get (caf_decl
);
1887 if (CLASS_DATA (comp
)->attr
.codimension
)
1893 if (comp
->attr
.codimension
)
1899 gcc_assert (found
&& caf_decl
);
1904 /* Obtain the Coarray token - and optionally also the offset. */
1907 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1908 tree se_expr
, gfc_expr
*expr
)
1912 /* Coarray token. */
1913 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1915 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1916 == GFC_ARRAY_ALLOCATABLE
1917 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1918 *token
= gfc_conv_descriptor_token (caf_decl
);
1920 else if (DECL_LANG_SPECIFIC (caf_decl
)
1921 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1922 *token
= GFC_DECL_TOKEN (caf_decl
);
1925 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1926 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1927 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1933 /* Offset between the coarray base address and the address wanted. */
1934 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1935 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1936 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1937 *offset
= build_int_cst (gfc_array_index_type
, 0);
1938 else if (DECL_LANG_SPECIFIC (caf_decl
)
1939 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1940 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1941 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1942 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1944 *offset
= build_int_cst (gfc_array_index_type
, 0);
1946 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1947 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1949 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1950 tmp
= gfc_conv_descriptor_data_get (tmp
);
1952 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1953 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1956 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1960 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1961 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1963 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1964 && expr
->symtree
->n
.sym
->attr
.codimension
1965 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
1967 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
1968 gfc_ref
*ref
= base_expr
->ref
;
1971 // Iterate through the refs until the last one.
1975 if (ref
->type
== REF_ARRAY
1976 && ref
->u
.ar
.type
!= AR_FULL
)
1978 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
1980 for (i
= 0; i
< ranksum
; ++i
)
1982 ref
->u
.ar
.start
[i
] = NULL
;
1983 ref
->u
.ar
.end
[i
] = NULL
;
1985 ref
->u
.ar
.type
= AR_FULL
;
1987 gfc_init_se (&base_se
, NULL
);
1988 if (gfc_caf_attr (base_expr
).dimension
)
1990 gfc_conv_expr_descriptor (&base_se
, base_expr
);
1991 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
1995 gfc_conv_expr (&base_se
, base_expr
);
1999 gfc_free_expr (base_expr
);
2000 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2001 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2003 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2004 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2007 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2011 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2012 fold_convert (gfc_array_index_type
, *offset
),
2013 fold_convert (gfc_array_index_type
, tmp
));
2017 /* Convert the coindex of a coarray into an image index; the result is
2018 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2019 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2022 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2025 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2029 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2030 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2032 gcc_assert (ref
!= NULL
);
2034 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2036 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2040 img_idx
= integer_zero_node
;
2041 extent
= integer_one_node
;
2042 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2043 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2045 gfc_init_se (&se
, NULL
);
2046 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2047 gfc_add_block_to_block (block
, &se
.pre
);
2048 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2049 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2050 integer_type_node
, se
.expr
,
2051 fold_convert(integer_type_node
, lbound
));
2052 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2054 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2056 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2058 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2059 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2060 tmp
= fold_convert (integer_type_node
, tmp
);
2061 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2062 integer_type_node
, extent
, tmp
);
2066 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2068 gfc_init_se (&se
, NULL
);
2069 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2070 gfc_add_block_to_block (block
, &se
.pre
);
2071 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2072 lbound
= fold_convert (integer_type_node
, lbound
);
2073 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2074 integer_type_node
, se
.expr
, lbound
);
2075 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2077 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2079 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2081 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2082 ubound
= fold_convert (integer_type_node
, ubound
);
2083 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2084 integer_type_node
, ubound
, lbound
);
2085 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2086 tmp
, integer_one_node
);
2087 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2088 integer_type_node
, extent
, tmp
);
2091 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2092 img_idx
, integer_one_node
);
2097 /* For each character array constructor subexpression without a ts.u.cl->length,
2098 replace it by its first element (if there aren't any elements, the length
2099 should already be set to zero). */
2102 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2104 gfc_actual_arglist
* arg
;
2110 switch (e
->expr_type
)
2114 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2115 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2119 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2123 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2124 flatten_array_ctors_without_strlen (arg
->expr
);
2129 /* We've found what we're looking for. */
2130 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2135 gcc_assert (e
->value
.constructor
);
2137 c
= gfc_constructor_first (e
->value
.constructor
);
2141 flatten_array_ctors_without_strlen (new_expr
);
2142 gfc_replace_expr (e
, new_expr
);
2146 /* Otherwise, fall through to handle constructor elements. */
2148 case EXPR_STRUCTURE
:
2149 for (c
= gfc_constructor_first (e
->value
.constructor
);
2150 c
; c
= gfc_constructor_next (c
))
2151 flatten_array_ctors_without_strlen (c
->expr
);
2161 /* Generate code to initialize a string length variable. Returns the
2162 value. For array constructors, cl->length might be NULL and in this case,
2163 the first element of the constructor is needed. expr is the original
2164 expression so we can access it but can be NULL if this is not needed. */
2167 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2171 gfc_init_se (&se
, NULL
);
2173 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2176 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2177 "flatten" array constructors by taking their first element; all elements
2178 should be the same length or a cl->length should be present. */
2181 gfc_expr
* expr_flat
;
2183 expr_flat
= gfc_copy_expr (expr
);
2184 flatten_array_ctors_without_strlen (expr_flat
);
2185 gfc_resolve_expr (expr_flat
);
2187 gfc_conv_expr (&se
, expr_flat
);
2188 gfc_add_block_to_block (pblock
, &se
.pre
);
2189 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2191 gfc_free_expr (expr_flat
);
2195 /* Convert cl->length. */
2197 gcc_assert (cl
->length
);
2199 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2200 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2201 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2202 gfc_add_block_to_block (pblock
, &se
.pre
);
2204 if (cl
->backend_decl
)
2205 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2207 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2212 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2213 const char *name
, locus
*where
)
2223 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2224 type
= build_pointer_type (type
);
2226 gfc_init_se (&start
, se
);
2227 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2228 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2230 if (integer_onep (start
.expr
))
2231 gfc_conv_string_parameter (se
);
2236 /* Avoid multiple evaluation of substring start. */
2237 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2238 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2240 /* Change the start of the string. */
2241 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2244 tmp
= build_fold_indirect_ref_loc (input_location
,
2246 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2247 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2250 /* Length = end + 1 - start. */
2251 gfc_init_se (&end
, se
);
2252 if (ref
->u
.ss
.end
== NULL
)
2253 end
.expr
= se
->string_length
;
2256 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2257 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2261 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2262 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2264 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2266 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2267 logical_type_node
, start
.expr
,
2270 /* Check lower bound. */
2271 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2273 build_int_cst (gfc_charlen_type_node
, 1));
2274 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2275 logical_type_node
, nonempty
, fault
);
2277 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2278 "is less than one", name
);
2280 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2281 "is less than one");
2282 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2283 fold_convert (long_integer_type_node
,
2287 /* Check upper bound. */
2288 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2289 end
.expr
, se
->string_length
);
2290 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2291 logical_type_node
, nonempty
, fault
);
2293 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2294 "exceeds string length (%%ld)", name
);
2296 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2297 "exceeds string length (%%ld)");
2298 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2299 fold_convert (long_integer_type_node
, end
.expr
),
2300 fold_convert (long_integer_type_node
,
2301 se
->string_length
));
2305 /* Try to calculate the length from the start and end expressions. */
2307 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2311 i_len
= mpz_get_si (length
) + 1;
2315 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2316 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2320 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2321 end
.expr
, start
.expr
);
2322 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2323 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2324 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2325 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2328 se
->string_length
= tmp
;
2332 /* Convert a derived type component reference. */
2335 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2343 c
= ref
->u
.c
.component
;
2345 if (c
->backend_decl
== NULL_TREE
2346 && ref
->u
.c
.sym
!= NULL
)
2347 gfc_get_derived_type (ref
->u
.c
.sym
);
2349 field
= c
->backend_decl
;
2350 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2352 context
= DECL_FIELD_CONTEXT (field
);
2354 /* Components can correspond to fields of different containing
2355 types, as components are created without context, whereas
2356 a concrete use of a component has the type of decl as context.
2357 So, if the type doesn't match, we search the corresponding
2358 FIELD_DECL in the parent type. To not waste too much time
2359 we cache this result in norestrict_decl.
2360 On the other hand, if the context is a UNION or a MAP (a
2361 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2363 if (context
!= TREE_TYPE (decl
)
2364 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2365 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2367 tree f2
= c
->norestrict_decl
;
2368 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2369 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2370 if (TREE_CODE (f2
) == FIELD_DECL
2371 && DECL_NAME (f2
) == DECL_NAME (field
))
2374 c
->norestrict_decl
= f2
;
2378 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2379 && strcmp ("_data", c
->name
) == 0)
2381 /* Found a ref to the _data component. Store the associated ref to
2382 the vptr in se->class_vptr. */
2383 se
->class_vptr
= gfc_class_vptr_get (decl
);
2386 se
->class_vptr
= NULL_TREE
;
2388 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2389 decl
, field
, NULL_TREE
);
2393 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2394 strlen () conditional below. */
2395 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2396 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2398 tmp
= c
->ts
.u
.cl
->backend_decl
;
2399 /* Components must always be constant length. */
2400 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2401 se
->string_length
= tmp
;
2404 if (gfc_deferred_strlen (c
, &field
))
2406 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2408 decl
, field
, NULL_TREE
);
2409 se
->string_length
= tmp
;
2412 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2413 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2414 && c
->ts
.type
!= BT_CHARACTER
)
2415 || c
->attr
.proc_pointer
)
2416 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2421 /* This function deals with component references to components of the
2422 parent type for derived type extensions. */
2424 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2432 c
= ref
->u
.c
.component
;
2434 /* Return if the component is in the parent type. */
2435 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2436 if (strcmp (c
->name
, cmp
->name
) == 0)
2439 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2440 parent
.type
= REF_COMPONENT
;
2442 parent
.u
.c
.sym
= dt
;
2443 parent
.u
.c
.component
= dt
->components
;
2445 if (dt
->backend_decl
== NULL
)
2446 gfc_get_derived_type (dt
);
2448 /* Build the reference and call self. */
2449 gfc_conv_component_ref (se
, &parent
);
2450 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2451 parent
.u
.c
.component
= c
;
2452 conv_parent_component_references (se
, &parent
);
2455 /* Return the contents of a variable. Also handles reference/pointer
2456 variables (all Fortran pointer references are implicit). */
2459 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2464 tree parent_decl
= NULL_TREE
;
2467 bool alternate_entry
;
2470 bool first_time
= true;
2472 sym
= expr
->symtree
->n
.sym
;
2473 is_classarray
= IS_CLASS_ARRAY (sym
);
2477 gfc_ss_info
*ss_info
= ss
->info
;
2479 /* Check that something hasn't gone horribly wrong. */
2480 gcc_assert (ss
!= gfc_ss_terminator
);
2481 gcc_assert (ss_info
->expr
== expr
);
2483 /* A scalarized term. We already know the descriptor. */
2484 se
->expr
= ss_info
->data
.array
.descriptor
;
2485 se
->string_length
= ss_info
->string_length
;
2486 ref
= ss_info
->data
.array
.ref
;
2488 gcc_assert (ref
->type
== REF_ARRAY
2489 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2491 gfc_conv_tmp_array_ref (se
);
2495 tree se_expr
= NULL_TREE
;
2497 se
->expr
= gfc_get_symbol_decl (sym
);
2499 /* Deal with references to a parent results or entries by storing
2500 the current_function_decl and moving to the parent_decl. */
2501 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2502 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2503 && sym
->result
== sym
;
2504 entry_master
= sym
->attr
.result
2505 && sym
->ns
->proc_name
->attr
.entry_master
2506 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2507 if (current_function_decl
)
2508 parent_decl
= DECL_CONTEXT (current_function_decl
);
2510 if ((se
->expr
== parent_decl
&& return_value
)
2511 || (sym
->ns
&& sym
->ns
->proc_name
2513 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2514 && (alternate_entry
|| entry_master
)))
2519 /* Special case for assigning the return value of a function.
2520 Self recursive functions must have an explicit return value. */
2521 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2522 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2524 /* Similarly for alternate entry points. */
2525 else if (alternate_entry
2526 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2529 gfc_entry_list
*el
= NULL
;
2531 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2534 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2539 else if (entry_master
2540 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2542 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2547 /* Procedure actual arguments. Look out for temporary variables
2548 with the same attributes as function values. */
2549 else if (!sym
->attr
.temporary
2550 && sym
->attr
.flavor
== FL_PROCEDURE
2551 && se
->expr
!= current_function_decl
)
2553 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2555 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2556 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2562 /* Dereference the expression, where needed. Since characters
2563 are entirely different from other types, they are treated
2565 if (sym
->ts
.type
== BT_CHARACTER
)
2567 /* Dereference character pointer dummy arguments
2569 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2571 || sym
->attr
.function
2572 || sym
->attr
.result
))
2573 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2577 else if (!sym
->attr
.value
)
2579 /* Dereference temporaries for class array dummy arguments. */
2580 if (sym
->attr
.dummy
&& is_classarray
2581 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2583 if (!se
->descriptor_only
)
2584 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2586 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2590 /* Dereference non-character scalar dummy arguments. */
2591 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2592 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2593 && (sym
->ts
.type
!= BT_CLASS
2594 || (!CLASS_DATA (sym
)->attr
.dimension
2595 && !(CLASS_DATA (sym
)->attr
.codimension
2596 && CLASS_DATA (sym
)->attr
.allocatable
))))
2597 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2600 /* Dereference scalar hidden result. */
2601 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2602 && (sym
->attr
.function
|| sym
->attr
.result
)
2603 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2604 && !sym
->attr
.always_explicit
)
2605 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2608 /* Dereference non-character, non-class pointer variables.
2609 These must be dummies, results, or scalars. */
2611 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2612 || gfc_is_associate_pointer (sym
)
2613 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2615 || sym
->attr
.function
2617 || (!sym
->attr
.dimension
2618 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2619 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2621 /* Now treat the class array pointer variables accordingly. */
2622 else if (sym
->ts
.type
== BT_CLASS
2624 && (CLASS_DATA (sym
)->attr
.dimension
2625 || CLASS_DATA (sym
)->attr
.codimension
)
2626 && ((CLASS_DATA (sym
)->as
2627 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2628 || CLASS_DATA (sym
)->attr
.allocatable
2629 || CLASS_DATA (sym
)->attr
.class_pointer
))
2630 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2632 /* And the case where a non-dummy, non-result, non-function,
2633 non-allotable and non-pointer classarray is present. This case was
2634 previously covered by the first if, but with introducing the
2635 condition !is_classarray there, that case has to be covered
2637 else if (sym
->ts
.type
== BT_CLASS
2639 && !sym
->attr
.function
2640 && !sym
->attr
.result
2641 && (CLASS_DATA (sym
)->attr
.dimension
2642 || CLASS_DATA (sym
)->attr
.codimension
)
2644 || !CLASS_DATA (sym
)->attr
.allocatable
)
2645 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2646 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2653 /* For character variables, also get the length. */
2654 if (sym
->ts
.type
== BT_CHARACTER
)
2656 /* If the character length of an entry isn't set, get the length from
2657 the master function instead. */
2658 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2659 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2661 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2662 gcc_assert (se
->string_length
);
2670 /* Return the descriptor if that's what we want and this is an array
2671 section reference. */
2672 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2674 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2675 /* Return the descriptor for array pointers and allocations. */
2676 if (se
->want_pointer
2677 && ref
->next
== NULL
&& (se
->descriptor_only
))
2680 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2681 /* Return a pointer to an element. */
2685 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2686 && se
->descriptor_only
2687 && !CLASS_DATA (sym
)->attr
.allocatable
2688 && !CLASS_DATA (sym
)->attr
.class_pointer
2689 && CLASS_DATA (sym
)->as
2690 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2691 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2692 /* Skip the first ref of a _data component, because for class
2693 arrays that one is already done by introducing a temporary
2694 array descriptor. */
2697 if (ref
->u
.c
.sym
->attr
.extension
)
2698 conv_parent_component_references (se
, ref
);
2700 gfc_conv_component_ref (se
, ref
);
2701 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2702 && se
->want_pointer
&& se
->descriptor_only
)
2708 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2709 expr
->symtree
->name
, &expr
->where
);
2719 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2721 if (se
->want_pointer
)
2723 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2724 gfc_conv_string_parameter (se
);
2726 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2731 /* Unary ops are easy... Or they would be if ! was a valid op. */
2734 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2739 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2740 /* Initialize the operand. */
2741 gfc_init_se (&operand
, se
);
2742 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2743 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2745 type
= gfc_typenode_for_spec (&expr
->ts
);
2747 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2748 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2749 All other unary operators have an equivalent GIMPLE unary operator. */
2750 if (code
== TRUTH_NOT_EXPR
)
2751 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2752 build_int_cst (type
, 0));
2754 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2758 /* Expand power operator to optimal multiplications when a value is raised
2759 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2760 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2761 Programming", 3rd Edition, 1998. */
2763 /* This code is mostly duplicated from expand_powi in the backend.
2764 We establish the "optimal power tree" lookup table with the defined size.
2765 The items in the table are the exponents used to calculate the index
2766 exponents. Any integer n less than the value can get an "addition chain",
2767 with the first node being one. */
2768 #define POWI_TABLE_SIZE 256
2770 /* The table is from builtins.c. */
2771 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2773 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2774 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2775 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2776 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2777 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2778 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2779 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2780 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2781 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2782 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2783 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2784 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2785 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2786 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2787 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2788 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2789 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2790 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2791 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2792 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2793 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2794 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2795 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2796 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2797 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2798 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2799 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2800 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2801 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2802 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2803 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2804 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2807 /* If n is larger than lookup table's max index, we use the "window
2809 #define POWI_WINDOW_SIZE 3
2811 /* Recursive function to expand the power operator. The temporary
2812 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2814 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2821 if (n
< POWI_TABLE_SIZE
)
2826 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2827 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2831 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2832 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2833 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2837 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2841 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2842 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2844 if (n
< POWI_TABLE_SIZE
)
2851 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2852 return 1. Else return 0 and a call to runtime library functions
2853 will have to be built. */
2855 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2860 tree vartmp
[POWI_TABLE_SIZE
];
2862 unsigned HOST_WIDE_INT n
;
2864 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2866 /* If exponent is too large, we won't expand it anyway, so don't bother
2867 with large integer values. */
2868 if (!wi::fits_shwi_p (wrhs
))
2871 m
= wrhs
.to_shwi ();
2872 /* Use the wide_int's routine to reliably get the absolute value on all
2873 platforms. Then convert it to a HOST_WIDE_INT like above. */
2874 n
= wi::abs (wrhs
).to_shwi ();
2876 type
= TREE_TYPE (lhs
);
2877 sgn
= tree_int_cst_sgn (rhs
);
2879 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2880 || optimize_size
) && (m
> 2 || m
< -1))
2886 se
->expr
= gfc_build_const (type
, integer_one_node
);
2890 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2891 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2893 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2894 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2895 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2896 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2899 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2902 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2903 logical_type_node
, tmp
, cond
);
2904 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2905 tmp
, build_int_cst (type
, 1),
2906 build_int_cst (type
, 0));
2910 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2911 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2912 build_int_cst (type
, -1),
2913 build_int_cst (type
, 0));
2914 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2915 cond
, build_int_cst (type
, 1), tmp
);
2919 memset (vartmp
, 0, sizeof (vartmp
));
2923 tmp
= gfc_build_const (type
, integer_one_node
);
2924 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2928 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2934 /* Power op (**). Constant integer exponent has special handling. */
2937 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2939 tree gfc_int4_type_node
;
2942 int res_ikind_1
, res_ikind_2
;
2947 gfc_init_se (&lse
, se
);
2948 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2949 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2950 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2952 gfc_init_se (&rse
, se
);
2953 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2954 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2956 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2957 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2958 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2961 gfc_int4_type_node
= gfc_get_int_type (4);
2963 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2964 library routine. But in the end, we have to convert the result back
2965 if this case applies -- with res_ikind_K, we keep track whether operand K
2966 falls into this case. */
2970 kind
= expr
->value
.op
.op1
->ts
.kind
;
2971 switch (expr
->value
.op
.op2
->ts
.type
)
2974 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2979 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2980 res_ikind_2
= ikind
;
3002 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3004 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3031 switch (expr
->value
.op
.op1
->ts
.type
)
3034 if (kind
== 3) /* Case 16 was not handled properly above. */
3036 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3040 /* Use builtins for real ** int4. */
3046 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3050 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3054 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3058 /* Use the __builtin_powil() only if real(kind=16) is
3059 actually the C long double type. */
3060 if (!gfc_real16_is_float128
)
3061 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3069 /* If we don't have a good builtin for this, go for the
3070 library function. */
3072 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3076 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3085 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3089 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3097 se
->expr
= build_call_expr_loc (input_location
,
3098 fndecl
, 2, lse
.expr
, rse
.expr
);
3100 /* Convert the result back if it is of wrong integer kind. */
3101 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3103 /* We want the maximum of both operand kinds as result. */
3104 if (res_ikind_1
< res_ikind_2
)
3105 res_ikind_1
= res_ikind_2
;
3106 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3111 /* Generate code to allocate a string temporary. */
3114 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3119 if (gfc_can_put_var_on_stack (len
))
3121 /* Create a temporary variable to hold the result. */
3122 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3123 gfc_charlen_type_node
, len
,
3124 build_int_cst (gfc_charlen_type_node
, 1));
3125 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3127 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3128 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3130 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3132 var
= gfc_create_var (tmp
, "str");
3133 var
= gfc_build_addr_expr (type
, var
);
3137 /* Allocate a temporary to hold the result. */
3138 var
= gfc_create_var (type
, "pstr");
3139 gcc_assert (POINTER_TYPE_P (type
));
3140 tmp
= TREE_TYPE (type
);
3141 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3142 tmp
= TREE_TYPE (tmp
);
3143 tmp
= TYPE_SIZE_UNIT (tmp
);
3144 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3145 fold_convert (size_type_node
, len
),
3146 fold_convert (size_type_node
, tmp
));
3147 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3148 gfc_add_modify (&se
->pre
, var
, tmp
);
3150 /* Free the temporary afterwards. */
3151 tmp
= gfc_call_free (var
);
3152 gfc_add_expr_to_block (&se
->post
, tmp
);
3159 /* Handle a string concatenation operation. A temporary will be allocated to
3163 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3166 tree len
, type
, var
, tmp
, fndecl
;
3168 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3169 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3170 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3172 gfc_init_se (&lse
, se
);
3173 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3174 gfc_conv_string_parameter (&lse
);
3175 gfc_init_se (&rse
, se
);
3176 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3177 gfc_conv_string_parameter (&rse
);
3179 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3180 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3182 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3183 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3184 if (len
== NULL_TREE
)
3186 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3187 TREE_TYPE (lse
.string_length
),
3188 lse
.string_length
, rse
.string_length
);
3191 type
= build_pointer_type (type
);
3193 var
= gfc_conv_string_tmp (se
, type
, len
);
3195 /* Do the actual concatenation. */
3196 if (expr
->ts
.kind
== 1)
3197 fndecl
= gfor_fndecl_concat_string
;
3198 else if (expr
->ts
.kind
== 4)
3199 fndecl
= gfor_fndecl_concat_string_char4
;
3203 tmp
= build_call_expr_loc (input_location
,
3204 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3205 rse
.string_length
, rse
.expr
);
3206 gfc_add_expr_to_block (&se
->pre
, tmp
);
3208 /* Add the cleanup for the operands. */
3209 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3210 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3213 se
->string_length
= len
;
3216 /* Translates an op expression. Common (binary) cases are handled by this
3217 function, others are passed on. Recursion is used in either case.
3218 We use the fact that (op1.ts == op2.ts) (except for the power
3220 Operators need no special handling for scalarized expressions as long as
3221 they call gfc_conv_simple_val to get their operands.
3222 Character strings get special handling. */
3225 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3227 enum tree_code code
;
3236 switch (expr
->value
.op
.op
)
3238 case INTRINSIC_PARENTHESES
:
3239 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3240 && flag_protect_parens
)
3242 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3243 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3248 case INTRINSIC_UPLUS
:
3249 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3252 case INTRINSIC_UMINUS
:
3253 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3257 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3260 case INTRINSIC_PLUS
:
3264 case INTRINSIC_MINUS
:
3268 case INTRINSIC_TIMES
:
3272 case INTRINSIC_DIVIDE
:
3273 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3274 an integer, we must round towards zero, so we use a
3276 if (expr
->ts
.type
== BT_INTEGER
)
3277 code
= TRUNC_DIV_EXPR
;
3282 case INTRINSIC_POWER
:
3283 gfc_conv_power_op (se
, expr
);
3286 case INTRINSIC_CONCAT
:
3287 gfc_conv_concat_op (se
, expr
);
3291 code
= TRUTH_ANDIF_EXPR
;
3296 code
= TRUTH_ORIF_EXPR
;
3300 /* EQV and NEQV only work on logicals, but since we represent them
3301 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3303 case INTRINSIC_EQ_OS
:
3311 case INTRINSIC_NE_OS
:
3312 case INTRINSIC_NEQV
:
3319 case INTRINSIC_GT_OS
:
3326 case INTRINSIC_GE_OS
:
3333 case INTRINSIC_LT_OS
:
3340 case INTRINSIC_LE_OS
:
3346 case INTRINSIC_USER
:
3347 case INTRINSIC_ASSIGN
:
3348 /* These should be converted into function calls by the frontend. */
3352 fatal_error (input_location
, "Unknown intrinsic op");
3356 /* The only exception to this is **, which is handled separately anyway. */
3357 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3359 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3363 gfc_init_se (&lse
, se
);
3364 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3365 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3368 gfc_init_se (&rse
, se
);
3369 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3370 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3374 gfc_conv_string_parameter (&lse
);
3375 gfc_conv_string_parameter (&rse
);
3377 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3378 rse
.string_length
, rse
.expr
,
3379 expr
->value
.op
.op1
->ts
.kind
,
3381 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3382 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3385 type
= gfc_typenode_for_spec (&expr
->ts
);
3389 /* The result of logical ops is always logical_type_node. */
3390 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3391 lse
.expr
, rse
.expr
);
3392 se
->expr
= convert (type
, tmp
);
3395 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3397 /* Add the post blocks. */
3398 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3399 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3402 /* If a string's length is one, we convert it to a single character. */
3405 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3409 || !tree_fits_uhwi_p (len
)
3410 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3413 if (TREE_INT_CST_LOW (len
) == 1)
3415 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3416 return build_fold_indirect_ref_loc (input_location
, str
);
3420 && TREE_CODE (str
) == ADDR_EXPR
3421 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3422 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3423 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3424 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3425 && TREE_INT_CST_LOW (len
) > 1
3426 && TREE_INT_CST_LOW (len
)
3427 == (unsigned HOST_WIDE_INT
)
3428 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3430 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3431 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3432 if (TREE_CODE (ret
) == INTEGER_CST
)
3434 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3435 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3436 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3438 for (i
= 1; i
< length
; i
++)
3451 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3454 if (sym
->backend_decl
)
3456 /* This becomes the nominal_type in
3457 function.c:assign_parm_find_data_types. */
3458 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3459 /* This becomes the passed_type in
3460 function.c:assign_parm_find_data_types. C promotes char to
3461 integer for argument passing. */
3462 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3464 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3469 /* If we have a constant character expression, make it into an
3471 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3476 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3477 (int)(*expr
)->value
.character
.string
[0]);
3478 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3480 /* The expr needs to be compatible with a C int. If the
3481 conversion fails, then the 2 causes an ICE. */
3482 ts
.type
= BT_INTEGER
;
3483 ts
.kind
= gfc_c_int_kind
;
3484 gfc_convert_type (*expr
, &ts
, 2);
3487 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3489 if ((*expr
)->ref
== NULL
)
3491 se
->expr
= gfc_string_to_single_character
3492 (build_int_cst (integer_type_node
, 1),
3493 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3495 ((*expr
)->symtree
->n
.sym
)),
3500 gfc_conv_variable (se
, *expr
);
3501 se
->expr
= gfc_string_to_single_character
3502 (build_int_cst (integer_type_node
, 1),
3503 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3511 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3512 if STR is a string literal, otherwise return -1. */
3515 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3518 && TREE_CODE (str
) == ADDR_EXPR
3519 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3520 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3521 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3522 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3523 && tree_fits_uhwi_p (len
)
3524 && tree_to_uhwi (len
) >= 1
3525 && tree_to_uhwi (len
)
3526 == (unsigned HOST_WIDE_INT
)
3527 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3529 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3530 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3531 if (TREE_CODE (folded
) == INTEGER_CST
)
3533 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3534 int length
= TREE_STRING_LENGTH (string_cst
);
3535 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3537 for (; length
> 0; length
--)
3538 if (ptr
[length
- 1] != ' ')
3547 /* Helper to build a call to memcmp. */
3550 build_memcmp_call (tree s1
, tree s2
, tree n
)
3554 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3555 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3557 s1
= fold_convert (pvoid_type_node
, s1
);
3559 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3560 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3562 s2
= fold_convert (pvoid_type_node
, s2
);
3564 n
= fold_convert (size_type_node
, n
);
3566 tmp
= build_call_expr_loc (input_location
,
3567 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3570 return fold_convert (integer_type_node
, tmp
);
3573 /* Compare two strings. If they are all single characters, the result is the
3574 subtraction of them. Otherwise, we build a library call. */
3577 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3578 enum tree_code code
)
3584 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3585 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3587 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3588 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3590 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3592 /* Deal with single character specially. */
3593 sc1
= fold_convert (integer_type_node
, sc1
);
3594 sc2
= fold_convert (integer_type_node
, sc2
);
3595 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3599 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3601 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3603 /* If one string is a string literal with LEN_TRIM longer
3604 than the length of the second string, the strings
3606 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3607 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3608 return integer_one_node
;
3609 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3610 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3611 return integer_one_node
;
3614 /* We can compare via memcpy if the strings are known to be equal
3615 in length and they are
3617 - kind=4 and the comparison is for (in)equality. */
3619 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3620 && tree_int_cst_equal (len1
, len2
)
3621 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3626 chartype
= gfc_get_char_type (kind
);
3627 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3628 fold_convert (TREE_TYPE(len1
),
3629 TYPE_SIZE_UNIT(chartype
)),
3631 return build_memcmp_call (str1
, str2
, tmp
);
3634 /* Build a call for the comparison. */
3636 fndecl
= gfor_fndecl_compare_string
;
3638 fndecl
= gfor_fndecl_compare_string_char4
;
3642 return build_call_expr_loc (input_location
, fndecl
, 4,
3643 len1
, str1
, len2
, str2
);
3647 /* Return the backend_decl for a procedure pointer component. */
3650 get_proc_ptr_comp (gfc_expr
*e
)
3656 gfc_init_se (&comp_se
, NULL
);
3657 e2
= gfc_copy_expr (e
);
3658 /* We have to restore the expr type later so that gfc_free_expr frees
3659 the exact same thing that was allocated.
3660 TODO: This is ugly. */
3661 old_type
= e2
->expr_type
;
3662 e2
->expr_type
= EXPR_VARIABLE
;
3663 gfc_conv_expr (&comp_se
, e2
);
3664 e2
->expr_type
= old_type
;
3666 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3670 /* Convert a typebound function reference from a class object. */
3672 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3677 if (!VAR_P (base_object
))
3679 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3680 gfc_add_modify (&se
->pre
, var
, base_object
);
3682 se
->expr
= gfc_class_vptr_get (base_object
);
3683 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3685 while (ref
&& ref
->next
)
3687 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3688 if (ref
->u
.c
.sym
->attr
.extension
)
3689 conv_parent_component_references (se
, ref
);
3690 gfc_conv_component_ref (se
, ref
);
3691 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3696 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3700 if (gfc_is_proc_ptr_comp (expr
))
3701 tmp
= get_proc_ptr_comp (expr
);
3702 else if (sym
->attr
.dummy
)
3704 tmp
= gfc_get_symbol_decl (sym
);
3705 if (sym
->attr
.proc_pointer
)
3706 tmp
= build_fold_indirect_ref_loc (input_location
,
3708 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3709 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3713 if (!sym
->backend_decl
)
3714 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3716 TREE_USED (sym
->backend_decl
) = 1;
3718 tmp
= sym
->backend_decl
;
3720 if (sym
->attr
.cray_pointee
)
3722 /* TODO - make the cray pointee a pointer to a procedure,
3723 assign the pointer to it and use it for the call. This
3725 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3726 gfc_get_symbol_decl (sym
->cp_pointer
));
3727 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3730 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3732 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3733 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3740 /* Initialize MAPPING. */
3743 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3745 mapping
->syms
= NULL
;
3746 mapping
->charlens
= NULL
;
3750 /* Free all memory held by MAPPING (but not MAPPING itself). */
3753 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3755 gfc_interface_sym_mapping
*sym
;
3756 gfc_interface_sym_mapping
*nextsym
;
3758 gfc_charlen
*nextcl
;
3760 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3762 nextsym
= sym
->next
;
3763 sym
->new_sym
->n
.sym
->formal
= NULL
;
3764 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3765 gfc_free_expr (sym
->expr
);
3766 free (sym
->new_sym
);
3769 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3772 gfc_free_expr (cl
->length
);
3778 /* Return a copy of gfc_charlen CL. Add the returned structure to
3779 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3781 static gfc_charlen
*
3782 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3785 gfc_charlen
*new_charlen
;
3787 new_charlen
= gfc_get_charlen ();
3788 new_charlen
->next
= mapping
->charlens
;
3789 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3791 mapping
->charlens
= new_charlen
;
3796 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3797 array variable that can be used as the actual argument for dummy
3798 argument SYM. Add any initialization code to BLOCK. PACKED is as
3799 for gfc_get_nodesc_array_type and DATA points to the first element
3800 in the passed array. */
3803 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3804 gfc_packed packed
, tree data
)
3809 type
= gfc_typenode_for_spec (&sym
->ts
);
3810 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3811 !sym
->attr
.target
&& !sym
->attr
.pointer
3812 && !sym
->attr
.proc_pointer
);
3814 var
= gfc_create_var (type
, "ifm");
3815 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3821 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3822 and offset of descriptorless array type TYPE given that it has the same
3823 size as DESC. Add any set-up code to BLOCK. */
3826 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3833 offset
= gfc_index_zero_node
;
3834 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3836 dim
= gfc_rank_cst
[n
];
3837 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3838 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3840 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3841 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3842 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3843 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3845 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3847 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3848 gfc_array_index_type
,
3849 gfc_conv_descriptor_ubound_get (desc
, dim
),
3850 gfc_conv_descriptor_lbound_get (desc
, dim
));
3851 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3852 gfc_array_index_type
,
3853 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3854 tmp
= gfc_evaluate_now (tmp
, block
);
3855 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3857 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3858 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3859 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3860 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3861 gfc_array_index_type
, offset
, tmp
);
3863 offset
= gfc_evaluate_now (offset
, block
);
3864 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3868 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3869 in SE. The caller may still use se->expr and se->string_length after
3870 calling this function. */
3873 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3874 gfc_symbol
* sym
, gfc_se
* se
,
3877 gfc_interface_sym_mapping
*sm
;
3881 gfc_symbol
*new_sym
;
3883 gfc_symtree
*new_symtree
;
3885 /* Create a new symbol to represent the actual argument. */
3886 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3887 new_sym
->ts
= sym
->ts
;
3888 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3889 new_sym
->attr
.referenced
= 1;
3890 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3891 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3892 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3893 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3894 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3895 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3896 new_sym
->attr
.function
= sym
->attr
.function
;
3898 /* Ensure that the interface is available and that
3899 descriptors are passed for array actual arguments. */
3900 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3902 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3903 new_sym
->attr
.always_explicit
3904 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3907 /* Create a fake symtree for it. */
3909 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3910 new_symtree
->n
.sym
= new_sym
;
3911 gcc_assert (new_symtree
== root
);
3913 /* Create a dummy->actual mapping. */
3914 sm
= XCNEW (gfc_interface_sym_mapping
);
3915 sm
->next
= mapping
->syms
;
3917 sm
->new_sym
= new_symtree
;
3918 sm
->expr
= gfc_copy_expr (expr
);
3921 /* Stabilize the argument's value. */
3922 if (!sym
->attr
.function
&& se
)
3923 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3925 if (sym
->ts
.type
== BT_CHARACTER
)
3927 /* Create a copy of the dummy argument's length. */
3928 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3929 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3931 /* If the length is specified as "*", record the length that
3932 the caller is passing. We should use the callee's length
3933 in all other cases. */
3934 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3936 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3937 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3944 /* Use the passed value as-is if the argument is a function. */
3945 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3948 /* If the argument is a pass-by-value scalar, use the value as is. */
3949 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3952 /* If the argument is either a string or a pointer to a string,
3953 convert it to a boundless character type. */
3954 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3956 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3957 tmp
= build_pointer_type (tmp
);
3958 if (sym
->attr
.pointer
)
3959 value
= build_fold_indirect_ref_loc (input_location
,
3963 value
= fold_convert (tmp
, value
);
3966 /* If the argument is a scalar, a pointer to an array or an allocatable,
3968 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3969 value
= build_fold_indirect_ref_loc (input_location
,
3972 /* For character(*), use the actual argument's descriptor. */
3973 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3974 value
= build_fold_indirect_ref_loc (input_location
,
3977 /* If the argument is an array descriptor, use it to determine
3978 information about the actual argument's shape. */
3979 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3980 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3982 /* Get the actual argument's descriptor. */
3983 desc
= build_fold_indirect_ref_loc (input_location
,
3986 /* Create the replacement variable. */
3987 tmp
= gfc_conv_descriptor_data_get (desc
);
3988 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3991 /* Use DESC to work out the upper bounds, strides and offset. */
3992 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3995 /* Otherwise we have a packed array. */
3996 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3997 PACKED_FULL
, se
->expr
);
3999 new_sym
->backend_decl
= value
;
4003 /* Called once all dummy argument mappings have been added to MAPPING,
4004 but before the mapping is used to evaluate expressions. Pre-evaluate
4005 the length of each argument, adding any initialization code to PRE and
4006 any finalization code to POST. */
4009 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4010 stmtblock_t
* pre
, stmtblock_t
* post
)
4012 gfc_interface_sym_mapping
*sym
;
4016 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4017 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4018 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4020 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4021 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4022 gfc_init_se (&se
, NULL
);
4023 gfc_conv_expr (&se
, expr
);
4024 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4025 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4026 gfc_add_block_to_block (pre
, &se
.pre
);
4027 gfc_add_block_to_block (post
, &se
.post
);
4029 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4034 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4038 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4039 gfc_constructor_base base
)
4042 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4044 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4047 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4048 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4049 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4055 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4059 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4064 for (; ref
; ref
= ref
->next
)
4068 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4070 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4071 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4072 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4080 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4081 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4087 /* Convert intrinsic function calls into result expressions. */
4090 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4098 arg1
= expr
->value
.function
.actual
->expr
;
4099 if (expr
->value
.function
.actual
->next
)
4100 arg2
= expr
->value
.function
.actual
->next
->expr
;
4104 sym
= arg1
->symtree
->n
.sym
;
4106 if (sym
->attr
.dummy
)
4111 switch (expr
->value
.function
.isym
->id
)
4114 /* TODO figure out why this condition is necessary. */
4115 if (sym
->attr
.function
4116 && (arg1
->ts
.u
.cl
->length
== NULL
4117 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4118 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4121 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4124 case GFC_ISYM_LEN_TRIM
:
4125 new_expr
= gfc_copy_expr (arg1
);
4126 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4131 gfc_replace_expr (arg1
, new_expr
);
4135 if (!sym
->as
|| sym
->as
->rank
== 0)
4138 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4140 dup
= mpz_get_si (arg2
->value
.integer
);
4145 dup
= sym
->as
->rank
;
4149 for (; d
< dup
; d
++)
4153 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4155 gfc_free_expr (new_expr
);
4159 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4160 gfc_get_int_expr (gfc_default_integer_kind
,
4162 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4164 new_expr
= gfc_multiply (new_expr
, tmp
);
4170 case GFC_ISYM_LBOUND
:
4171 case GFC_ISYM_UBOUND
:
4172 /* TODO These implementations of lbound and ubound do not limit if
4173 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4175 if (!sym
->as
|| sym
->as
->rank
== 0)
4178 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4179 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4183 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4185 if (sym
->as
->lower
[d
])
4186 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4190 if (sym
->as
->upper
[d
])
4191 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4199 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4203 gfc_replace_expr (expr
, new_expr
);
4209 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4210 gfc_interface_mapping
* mapping
)
4212 gfc_formal_arglist
*f
;
4213 gfc_actual_arglist
*actual
;
4215 actual
= expr
->value
.function
.actual
;
4216 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4218 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4223 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4226 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4231 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4233 for (d
= 0; d
< as
->rank
; d
++)
4235 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4236 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4239 expr
->value
.function
.esym
->as
= as
;
4242 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4244 expr
->value
.function
.esym
->ts
.u
.cl
->length
4245 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4247 gfc_apply_interface_mapping_to_expr (mapping
,
4248 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4253 /* EXPR is a copy of an expression that appeared in the interface
4254 associated with MAPPING. Walk it recursively looking for references to
4255 dummy arguments that MAPPING maps to actual arguments. Replace each such
4256 reference with a reference to the associated actual argument. */
4259 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4262 gfc_interface_sym_mapping
*sym
;
4263 gfc_actual_arglist
*actual
;
4268 /* Copying an expression does not copy its length, so do that here. */
4269 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4271 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4272 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4275 /* Apply the mapping to any references. */
4276 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4278 /* ...and to the expression's symbol, if it has one. */
4279 /* TODO Find out why the condition on expr->symtree had to be moved into
4280 the loop rather than being outside it, as originally. */
4281 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4282 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4284 if (sym
->new_sym
->n
.sym
->backend_decl
)
4285 expr
->symtree
= sym
->new_sym
;
4287 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4290 /* ...and to subexpressions in expr->value. */
4291 switch (expr
->expr_type
)
4296 case EXPR_SUBSTRING
:
4300 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4301 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4305 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4306 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4308 if (expr
->value
.function
.esym
== NULL
4309 && expr
->value
.function
.isym
!= NULL
4310 && expr
->value
.function
.actual
->expr
->symtree
4311 && gfc_map_intrinsic_function (expr
, mapping
))
4314 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4315 if (sym
->old
== expr
->value
.function
.esym
)
4317 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4318 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4319 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4324 case EXPR_STRUCTURE
:
4325 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4338 /* Evaluate interface expression EXPR using MAPPING. Store the result
4342 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4343 gfc_se
* se
, gfc_expr
* expr
)
4345 expr
= gfc_copy_expr (expr
);
4346 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4347 gfc_conv_expr (se
, expr
);
4348 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4349 gfc_free_expr (expr
);
4353 /* Returns a reference to a temporary array into which a component of
4354 an actual argument derived type array is copied and then returned
4355 after the function call. */
4357 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4358 sym_intent intent
, bool formal_ptr
)
4366 gfc_array_info
*info
;
4376 gfc_init_se (&lse
, NULL
);
4377 gfc_init_se (&rse
, NULL
);
4379 /* Walk the argument expression. */
4380 rss
= gfc_walk_expr (expr
);
4382 gcc_assert (rss
!= gfc_ss_terminator
);
4384 /* Initialize the scalarizer. */
4385 gfc_init_loopinfo (&loop
);
4386 gfc_add_ss_to_loop (&loop
, rss
);
4388 /* Calculate the bounds of the scalarization. */
4389 gfc_conv_ss_startstride (&loop
);
4391 /* Build an ss for the temporary. */
4392 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4393 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4395 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4396 if (GFC_ARRAY_TYPE_P (base_type
)
4397 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4398 base_type
= gfc_get_element_type (base_type
);
4400 if (expr
->ts
.type
== BT_CLASS
)
4401 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4403 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4404 ? expr
->ts
.u
.cl
->backend_decl
4408 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4410 /* Associate the SS with the loop. */
4411 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4413 /* Setup the scalarizing loops. */
4414 gfc_conv_loop_setup (&loop
, &expr
->where
);
4416 /* Pass the temporary descriptor back to the caller. */
4417 info
= &loop
.temp_ss
->info
->data
.array
;
4418 parmse
->expr
= info
->descriptor
;
4420 /* Setup the gfc_se structures. */
4421 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4422 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4425 lse
.ss
= loop
.temp_ss
;
4426 gfc_mark_ss_chain_used (rss
, 1);
4427 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4429 /* Start the scalarized loop body. */
4430 gfc_start_scalarized_body (&loop
, &body
);
4432 /* Translate the expression. */
4433 gfc_conv_expr (&rse
, expr
);
4435 /* Reset the offset for the function call since the loop
4436 is zero based on the data pointer. Note that the temp
4437 comes first in the loop chain since it is added second. */
4438 if (gfc_is_alloc_class_array_function (expr
))
4440 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4441 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4442 gfc_index_zero_node
);
4445 gfc_conv_tmp_array_ref (&lse
);
4447 if (intent
!= INTENT_OUT
)
4449 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4450 gfc_add_expr_to_block (&body
, tmp
);
4451 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4452 gfc_trans_scalarizing_loops (&loop
, &body
);
4456 /* Make sure that the temporary declaration survives by merging
4457 all the loop declarations into the current context. */
4458 for (n
= 0; n
< loop
.dimen
; n
++)
4460 gfc_merge_block_scope (&body
);
4461 body
= loop
.code
[loop
.order
[n
]];
4463 gfc_merge_block_scope (&body
);
4466 /* Add the post block after the second loop, so that any
4467 freeing of allocated memory is done at the right time. */
4468 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4470 /**********Copy the temporary back again.*********/
4472 gfc_init_se (&lse
, NULL
);
4473 gfc_init_se (&rse
, NULL
);
4475 /* Walk the argument expression. */
4476 lss
= gfc_walk_expr (expr
);
4477 rse
.ss
= loop
.temp_ss
;
4480 /* Initialize the scalarizer. */
4481 gfc_init_loopinfo (&loop2
);
4482 gfc_add_ss_to_loop (&loop2
, lss
);
4484 dimen
= rse
.ss
->dimen
;
4486 /* Skip the write-out loop for this case. */
4487 if (gfc_is_alloc_class_array_function (expr
))
4488 goto class_array_fcn
;
4490 /* Calculate the bounds of the scalarization. */
4491 gfc_conv_ss_startstride (&loop2
);
4493 /* Setup the scalarizing loops. */
4494 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4496 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4497 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4499 gfc_mark_ss_chain_used (lss
, 1);
4500 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4502 /* Declare the variable to hold the temporary offset and start the
4503 scalarized loop body. */
4504 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4505 gfc_start_scalarized_body (&loop2
, &body
);
4507 /* Build the offsets for the temporary from the loop variables. The
4508 temporary array has lbounds of zero and strides of one in all
4509 dimensions, so this is very simple. The offset is only computed
4510 outside the innermost loop, so the overall transfer could be
4511 optimized further. */
4512 info
= &rse
.ss
->info
->data
.array
;
4514 tmp_index
= gfc_index_zero_node
;
4515 for (n
= dimen
- 1; n
> 0; n
--)
4518 tmp
= rse
.loop
->loopvar
[n
];
4519 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4520 tmp
, rse
.loop
->from
[n
]);
4521 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4524 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4525 gfc_array_index_type
,
4526 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4527 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4528 gfc_array_index_type
,
4529 tmp_str
, gfc_index_one_node
);
4531 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4532 gfc_array_index_type
, tmp
, tmp_str
);
4535 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4536 gfc_array_index_type
,
4537 tmp_index
, rse
.loop
->from
[0]);
4538 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4540 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4541 gfc_array_index_type
,
4542 rse
.loop
->loopvar
[0], offset
);
4544 /* Now use the offset for the reference. */
4545 tmp
= build_fold_indirect_ref_loc (input_location
,
4547 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4549 if (expr
->ts
.type
== BT_CHARACTER
)
4550 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4552 gfc_conv_expr (&lse
, expr
);
4554 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4556 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4557 gfc_add_expr_to_block (&body
, tmp
);
4559 /* Generate the copying loops. */
4560 gfc_trans_scalarizing_loops (&loop2
, &body
);
4562 /* Wrap the whole thing up by adding the second loop to the post-block
4563 and following it by the post-block of the first loop. In this way,
4564 if the temporary needs freeing, it is done after use! */
4565 if (intent
!= INTENT_IN
)
4567 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4568 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4573 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4575 gfc_cleanup_loop (&loop
);
4576 gfc_cleanup_loop (&loop2
);
4578 /* Pass the string length to the argument expression. */
4579 if (expr
->ts
.type
== BT_CHARACTER
)
4580 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4582 /* Determine the offset for pointer formal arguments and set the
4586 size
= gfc_index_one_node
;
4587 offset
= gfc_index_zero_node
;
4588 for (n
= 0; n
< dimen
; n
++)
4590 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4592 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4593 gfc_array_index_type
, tmp
,
4594 gfc_index_one_node
);
4595 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4599 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4602 gfc_index_one_node
);
4603 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4604 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4605 gfc_array_index_type
,
4607 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4608 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4609 gfc_array_index_type
,
4610 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4611 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4612 gfc_array_index_type
,
4613 tmp
, gfc_index_one_node
);
4614 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4615 gfc_array_index_type
, size
, tmp
);
4618 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4622 /* We want either the address for the data or the address of the descriptor,
4623 depending on the mode of passing array arguments. */
4625 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4627 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4633 /* Generate the code for argument list functions. */
4636 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4638 /* Pass by value for g77 %VAL(arg), pass the address
4639 indirectly for %LOC, else by reference. Thus %REF
4640 is a "do-nothing" and %LOC is the same as an F95
4642 if (strncmp (name
, "%VAL", 4) == 0)
4643 gfc_conv_expr (se
, expr
);
4644 else if (strncmp (name
, "%LOC", 4) == 0)
4646 gfc_conv_expr_reference (se
, expr
);
4647 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4649 else if (strncmp (name
, "%REF", 4) == 0)
4650 gfc_conv_expr_reference (se
, expr
);
4652 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4656 /* This function tells whether the middle-end representation of the expression
4657 E given as input may point to data otherwise accessible through a variable
4659 It is assumed that the only expressions that may alias are variables,
4660 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4662 This function is used to decide whether freeing an expression's allocatable
4663 components is safe or should be avoided.
4665 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4666 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4667 is necessary because for array constructors, aliasing depends on how
4669 - If E is an array constructor used as argument to an elemental procedure,
4670 the array, which is generated through shallow copy by the scalarizer,
4671 is used directly and can alias the expressions it was copied from.
4672 - If E is an array constructor used as argument to a non-elemental
4673 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4674 the array as in the previous case, but then that array is used
4675 to initialize a new descriptor through deep copy. There is no alias
4676 possible in that case.
4677 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4681 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4685 if (e
->expr_type
== EXPR_VARIABLE
)
4687 else if (e
->expr_type
== EXPR_FUNCTION
)
4689 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4691 if (proc_ifc
->result
!= NULL
4692 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4693 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4694 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4695 || proc_ifc
->result
->attr
.pointer
))
4700 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4703 for (c
= gfc_constructor_first (e
->value
.constructor
);
4704 c
; c
= gfc_constructor_next (c
))
4706 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4713 /* Generate code for a procedure call. Note can return se->post != NULL.
4714 If se->direct_byref is set then se->expr contains the return parameter.
4715 Return nonzero, if the call has alternate specifiers.
4716 'expr' is only needed for procedure pointer components. */
4719 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4720 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4721 vec
<tree
, va_gc
> *append_args
)
4723 gfc_interface_mapping mapping
;
4724 vec
<tree
, va_gc
> *arglist
;
4725 vec
<tree
, va_gc
> *retargs
;
4729 gfc_array_info
*info
;
4736 vec
<tree
, va_gc
> *stringargs
;
4737 vec
<tree
, va_gc
> *optionalargs
;
4739 gfc_formal_arglist
*formal
;
4740 gfc_actual_arglist
*arg
;
4741 int has_alternate_specifier
= 0;
4742 bool need_interface_mapping
;
4750 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4751 gfc_component
*comp
= NULL
;
4758 optionalargs
= NULL
;
4763 comp
= gfc_get_proc_ptr_comp (expr
);
4765 bool elemental_proc
= (comp
4766 && comp
->ts
.interface
4767 && comp
->ts
.interface
->attr
.elemental
)
4768 || (comp
&& comp
->attr
.elemental
)
4769 || sym
->attr
.elemental
;
4773 if (!elemental_proc
)
4775 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4776 if (se
->ss
->info
->useflags
)
4778 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4779 && sym
->result
->attr
.dimension
)
4780 || (comp
&& comp
->attr
.dimension
)
4781 || gfc_is_alloc_class_array_function (expr
));
4782 gcc_assert (se
->loop
!= NULL
);
4783 /* Access the previously obtained result. */
4784 gfc_conv_tmp_array_ref (se
);
4788 info
= &se
->ss
->info
->data
.array
;
4793 gfc_init_block (&post
);
4794 gfc_init_interface_mapping (&mapping
);
4797 formal
= gfc_sym_get_dummy_args (sym
);
4798 need_interface_mapping
= sym
->attr
.dimension
||
4799 (sym
->ts
.type
== BT_CHARACTER
4800 && sym
->ts
.u
.cl
->length
4801 && sym
->ts
.u
.cl
->length
->expr_type
4806 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4807 need_interface_mapping
= comp
->attr
.dimension
||
4808 (comp
->ts
.type
== BT_CHARACTER
4809 && comp
->ts
.u
.cl
->length
4810 && comp
->ts
.u
.cl
->length
->expr_type
4814 base_object
= NULL_TREE
;
4815 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4816 is the third and fourth argument to such a function call a value
4817 denoting the number of elements to copy (i.e., most of the time the
4818 length of a deferred length string). */
4819 ulim_copy
= (formal
== NULL
)
4820 && UNLIMITED_POLY (sym
)
4821 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4823 /* Evaluate the arguments. */
4824 for (arg
= args
, argc
= 0; arg
!= NULL
;
4825 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4828 fsym
= formal
? formal
->sym
: NULL
;
4829 parm_kind
= MISSING
;
4831 /* If the procedure requires an explicit interface, the actual
4832 argument is passed according to the corresponding formal
4833 argument. If the corresponding formal argument is a POINTER,
4834 ALLOCATABLE or assumed shape, we do not use g77's calling
4835 convention, and pass the address of the array descriptor
4836 instead. Otherwise we use g77's calling convention, in other words
4837 pass the array data pointer without descriptor. */
4838 bool nodesc_arg
= fsym
!= NULL
4839 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4841 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4842 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4844 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4846 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4848 /* Class array expressions are sometimes coming completely unadorned
4849 with either arrayspec or _data component. Correct that here.
4850 OOP-TODO: Move this to the frontend. */
4851 if (e
&& e
->expr_type
== EXPR_VARIABLE
4853 && e
->ts
.type
== BT_CLASS
4854 && (CLASS_DATA (e
)->attr
.codimension
4855 || CLASS_DATA (e
)->attr
.dimension
))
4857 gfc_typespec temp_ts
= e
->ts
;
4858 gfc_add_class_array_ref (e
);
4864 if (se
->ignore_optional
)
4866 /* Some intrinsics have already been resolved to the correct
4870 else if (arg
->label
)
4872 has_alternate_specifier
= 1;
4877 gfc_init_se (&parmse
, NULL
);
4879 /* For scalar arguments with VALUE attribute which are passed by
4880 value, pass "0" and a hidden argument gives the optional
4882 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4883 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4884 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4886 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4888 vec_safe_push (optionalargs
, boolean_false_node
);
4892 /* Pass a NULL pointer for an absent arg. */
4893 parmse
.expr
= null_pointer_node
;
4894 if (arg
->missing_arg_type
== BT_CHARACTER
)
4895 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4900 else if (arg
->expr
->expr_type
== EXPR_NULL
4901 && fsym
&& !fsym
->attr
.pointer
4902 && (fsym
->ts
.type
!= BT_CLASS
4903 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4905 /* Pass a NULL pointer to denote an absent arg. */
4906 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4907 && (fsym
->ts
.type
!= BT_CLASS
4908 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4909 gfc_init_se (&parmse
, NULL
);
4910 parmse
.expr
= null_pointer_node
;
4911 if (arg
->missing_arg_type
== BT_CHARACTER
)
4912 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4914 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4915 && e
->ts
.type
== BT_DERIVED
)
4917 /* The derived type needs to be converted to a temporary
4919 gfc_init_se (&parmse
, se
);
4920 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4922 && e
->expr_type
== EXPR_VARIABLE
4923 && e
->symtree
->n
.sym
->attr
.optional
,
4924 CLASS_DATA (fsym
)->attr
.class_pointer
4925 || CLASS_DATA (fsym
)->attr
.allocatable
);
4927 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4929 /* The intrinsic type needs to be converted to a temporary
4930 CLASS object for the unlimited polymorphic formal. */
4931 gfc_init_se (&parmse
, se
);
4932 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4934 else if (se
->ss
&& se
->ss
->info
->useflags
)
4940 /* An elemental function inside a scalarized loop. */
4941 gfc_init_se (&parmse
, se
);
4942 parm_kind
= ELEMENTAL
;
4944 /* When no fsym is present, ulim_copy is set and this is a third or
4945 fourth argument, use call-by-value instead of by reference to
4946 hand the length properties to the copy routine (i.e., most of the
4947 time this will be a call to a __copy_character_* routine where the
4948 third and fourth arguments are the lengths of a deferred length
4950 if ((fsym
&& fsym
->attr
.value
)
4951 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4952 gfc_conv_expr (&parmse
, e
);
4954 gfc_conv_expr_reference (&parmse
, e
);
4956 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4957 && e
->expr_type
== EXPR_FUNCTION
)
4958 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4961 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4962 && gfc_is_class_container_ref (e
))
4964 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4966 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4967 && e
->symtree
->n
.sym
->attr
.optional
)
4969 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4970 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4971 TREE_TYPE (parmse
.expr
),
4973 fold_convert (TREE_TYPE (parmse
.expr
),
4974 null_pointer_node
));
4978 /* If we are passing an absent array as optional dummy to an
4979 elemental procedure, make sure that we pass NULL when the data
4980 pointer is NULL. We need this extra conditional because of
4981 scalarization which passes arrays elements to the procedure,
4982 ignoring the fact that the array can be absent/unallocated/... */
4983 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4985 tree descriptor_data
;
4987 descriptor_data
= ss
->info
->data
.array
.data
;
4988 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4990 fold_convert (TREE_TYPE (descriptor_data
),
4991 null_pointer_node
));
4993 = fold_build3_loc (input_location
, COND_EXPR
,
4994 TREE_TYPE (parmse
.expr
),
4995 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4996 fold_convert (TREE_TYPE (parmse
.expr
),
5001 /* The scalarizer does not repackage the reference to a class
5002 array - instead it returns a pointer to the data element. */
5003 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5004 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5005 fsym
->attr
.intent
!= INTENT_IN
5006 && (CLASS_DATA (fsym
)->attr
.class_pointer
5007 || CLASS_DATA (fsym
)->attr
.allocatable
),
5009 && e
->expr_type
== EXPR_VARIABLE
5010 && e
->symtree
->n
.sym
->attr
.optional
,
5011 CLASS_DATA (fsym
)->attr
.class_pointer
5012 || CLASS_DATA (fsym
)->attr
.allocatable
);
5019 gfc_init_se (&parmse
, NULL
);
5021 /* Check whether the expression is a scalar or not; we cannot use
5022 e->rank as it can be nonzero for functions arguments. */
5023 argss
= gfc_walk_expr (e
);
5024 scalar
= argss
== gfc_ss_terminator
;
5026 gfc_free_ss_chain (argss
);
5028 /* Special handling for passing scalar polymorphic coarrays;
5029 otherwise one passes "class->_data.data" instead of "&class". */
5030 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5031 && fsym
&& fsym
->ts
.type
== BT_CLASS
5032 && CLASS_DATA (fsym
)->attr
.codimension
5033 && !CLASS_DATA (fsym
)->attr
.dimension
)
5035 gfc_add_class_array_ref (e
);
5036 parmse
.want_coarray
= 1;
5040 /* A scalar or transformational function. */
5043 if (e
->expr_type
== EXPR_VARIABLE
5044 && e
->symtree
->n
.sym
->attr
.cray_pointee
5045 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5047 /* The Cray pointer needs to be converted to a pointer to
5048 a type given by the expression. */
5049 gfc_conv_expr (&parmse
, e
);
5050 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5051 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5052 parmse
.expr
= convert (type
, tmp
);
5054 else if (fsym
&& fsym
->attr
.value
)
5056 if (fsym
->ts
.type
== BT_CHARACTER
5057 && fsym
->ts
.is_c_interop
5058 && fsym
->ns
->proc_name
!= NULL
5059 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5062 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5063 if (parmse
.expr
== NULL
)
5064 gfc_conv_expr (&parmse
, e
);
5068 gfc_conv_expr (&parmse
, e
);
5069 if (fsym
->attr
.optional
5070 && fsym
->ts
.type
!= BT_CLASS
5071 && fsym
->ts
.type
!= BT_DERIVED
)
5073 if (e
->expr_type
!= EXPR_VARIABLE
5074 || !e
->symtree
->n
.sym
->attr
.optional
5076 vec_safe_push (optionalargs
, boolean_true_node
);
5079 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5080 if (!e
->symtree
->n
.sym
->attr
.value
)
5082 = fold_build3_loc (input_location
, COND_EXPR
,
5083 TREE_TYPE (parmse
.expr
),
5085 fold_convert (TREE_TYPE (parmse
.expr
),
5086 integer_zero_node
));
5088 vec_safe_push (optionalargs
, tmp
);
5093 else if (arg
->name
&& arg
->name
[0] == '%')
5094 /* Argument list functions %VAL, %LOC and %REF are signalled
5095 through arg->name. */
5096 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5097 else if ((e
->expr_type
== EXPR_FUNCTION
)
5098 && ((e
->value
.function
.esym
5099 && e
->value
.function
.esym
->result
->attr
.pointer
)
5100 || (!e
->value
.function
.esym
5101 && e
->symtree
->n
.sym
->attr
.pointer
))
5102 && fsym
&& fsym
->attr
.target
)
5104 gfc_conv_expr (&parmse
, e
);
5105 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5107 else if (e
->expr_type
== EXPR_FUNCTION
5108 && e
->symtree
->n
.sym
->result
5109 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5110 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5112 /* Functions returning procedure pointers. */
5113 gfc_conv_expr (&parmse
, e
);
5114 if (fsym
&& fsym
->attr
.proc_pointer
)
5115 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5119 if (e
->ts
.type
== BT_CLASS
&& fsym
5120 && fsym
->ts
.type
== BT_CLASS
5121 && (!CLASS_DATA (fsym
)->as
5122 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5123 && CLASS_DATA (e
)->attr
.codimension
)
5125 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5126 gcc_assert (!CLASS_DATA (fsym
)->as
);
5127 gfc_add_class_array_ref (e
);
5128 parmse
.want_coarray
= 1;
5129 gfc_conv_expr_reference (&parmse
, e
);
5130 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5132 && e
->expr_type
== EXPR_VARIABLE
);
5134 else if (e
->ts
.type
== BT_CLASS
&& fsym
5135 && fsym
->ts
.type
== BT_CLASS
5136 && !CLASS_DATA (fsym
)->as
5137 && !CLASS_DATA (e
)->as
5138 && strcmp (fsym
->ts
.u
.derived
->name
,
5139 e
->ts
.u
.derived
->name
))
5141 type
= gfc_typenode_for_spec (&fsym
->ts
);
5142 var
= gfc_create_var (type
, fsym
->name
);
5143 gfc_conv_expr (&parmse
, e
);
5144 if (fsym
->attr
.optional
5145 && e
->expr_type
== EXPR_VARIABLE
5146 && e
->symtree
->n
.sym
->attr
.optional
)
5150 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5151 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5152 logical_type_node
, tmp
,
5153 fold_convert (TREE_TYPE (tmp
),
5154 null_pointer_node
));
5155 gfc_start_block (&block
);
5156 gfc_add_modify (&block
, var
,
5157 fold_build1_loc (input_location
,
5159 type
, parmse
.expr
));
5160 gfc_add_expr_to_block (&parmse
.pre
,
5161 fold_build3_loc (input_location
,
5162 COND_EXPR
, void_type_node
,
5163 cond
, gfc_finish_block (&block
),
5164 build_empty_stmt (input_location
)));
5165 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5166 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5167 TREE_TYPE (parmse
.expr
),
5169 fold_convert (TREE_TYPE (parmse
.expr
),
5170 null_pointer_node
));
5174 /* Since the internal representation of unlimited
5175 polymorphic expressions includes an extra field
5176 that other class objects do not, a cast to the
5177 formal type does not work. */
5178 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5182 /* Set the _data field. */
5183 tmp
= gfc_class_data_get (var
);
5184 efield
= fold_convert (TREE_TYPE (tmp
),
5185 gfc_class_data_get (parmse
.expr
));
5186 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5188 /* Set the _vptr field. */
5189 tmp
= gfc_class_vptr_get (var
);
5190 efield
= fold_convert (TREE_TYPE (tmp
),
5191 gfc_class_vptr_get (parmse
.expr
));
5192 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5194 /* Set the _len field. */
5195 tmp
= gfc_class_len_get (var
);
5196 gfc_add_modify (&parmse
.pre
, tmp
,
5197 build_int_cst (TREE_TYPE (tmp
), 0));
5201 tmp
= fold_build1_loc (input_location
,
5204 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5207 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5211 gfc_conv_expr_reference (&parmse
, e
);
5213 /* Catch base objects that are not variables. */
5214 if (e
->ts
.type
== BT_CLASS
5215 && e
->expr_type
!= EXPR_VARIABLE
5216 && expr
&& e
== expr
->base_expr
)
5217 base_object
= build_fold_indirect_ref_loc (input_location
,
5220 /* A class array element needs converting back to be a
5221 class object, if the formal argument is a class object. */
5222 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5223 && e
->ts
.type
== BT_CLASS
5224 && ((CLASS_DATA (fsym
)->as
5225 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5226 || CLASS_DATA (e
)->attr
.dimension
))
5227 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5228 fsym
->attr
.intent
!= INTENT_IN
5229 && (CLASS_DATA (fsym
)->attr
.class_pointer
5230 || CLASS_DATA (fsym
)->attr
.allocatable
),
5232 && e
->expr_type
== EXPR_VARIABLE
5233 && e
->symtree
->n
.sym
->attr
.optional
,
5234 CLASS_DATA (fsym
)->attr
.class_pointer
5235 || CLASS_DATA (fsym
)->attr
.allocatable
);
5237 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5238 allocated on entry, it must be deallocated. */
5239 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5240 && (fsym
->attr
.allocatable
5241 || (fsym
->ts
.type
== BT_CLASS
5242 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5247 gfc_init_block (&block
);
5249 if (e
->ts
.type
== BT_CLASS
)
5250 ptr
= gfc_class_data_get (ptr
);
5252 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5255 gfc_add_expr_to_block (&block
, tmp
);
5256 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5257 void_type_node
, ptr
,
5259 gfc_add_expr_to_block (&block
, tmp
);
5261 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5263 gfc_add_modify (&block
, ptr
,
5264 fold_convert (TREE_TYPE (ptr
),
5265 null_pointer_node
));
5266 gfc_add_expr_to_block (&block
, tmp
);
5268 else if (fsym
->ts
.type
== BT_CLASS
)
5271 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5272 tmp
= gfc_get_symbol_decl (vtab
);
5273 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5274 ptr
= gfc_class_vptr_get (parmse
.expr
);
5275 gfc_add_modify (&block
, ptr
,
5276 fold_convert (TREE_TYPE (ptr
), tmp
));
5277 gfc_add_expr_to_block (&block
, tmp
);
5280 if (fsym
->attr
.optional
5281 && e
->expr_type
== EXPR_VARIABLE
5282 && e
->symtree
->n
.sym
->attr
.optional
)
5284 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5286 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5287 gfc_finish_block (&block
),
5288 build_empty_stmt (input_location
));
5291 tmp
= gfc_finish_block (&block
);
5293 gfc_add_expr_to_block (&se
->pre
, tmp
);
5296 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5297 || fsym
->ts
.type
== BT_ASSUMED
)
5298 && e
->ts
.type
== BT_CLASS
5299 && !CLASS_DATA (e
)->attr
.dimension
5300 && !CLASS_DATA (e
)->attr
.codimension
)
5301 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5303 /* Wrap scalar variable in a descriptor. We need to convert
5304 the address of a pointer back to the pointer itself before,
5305 we can assign it to the data field. */
5307 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5308 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5311 if (TREE_CODE (tmp
) == ADDR_EXPR
5312 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5313 tmp
= TREE_OPERAND (tmp
, 0);
5314 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5316 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5319 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5320 && ((fsym
->attr
.pointer
5321 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5322 || (fsym
->attr
.proc_pointer
5323 && !(e
->expr_type
== EXPR_VARIABLE
5324 && e
->symtree
->n
.sym
->attr
.dummy
))
5325 || (fsym
->attr
.proc_pointer
5326 && e
->expr_type
== EXPR_VARIABLE
5327 && gfc_is_proc_ptr_comp (e
))
5328 || (fsym
->attr
.allocatable
5329 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5331 /* Scalar pointer dummy args require an extra level of
5332 indirection. The null pointer already contains
5333 this level of indirection. */
5334 parm_kind
= SCALAR_POINTER
;
5335 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5339 else if (e
->ts
.type
== BT_CLASS
5340 && fsym
&& fsym
->ts
.type
== BT_CLASS
5341 && (CLASS_DATA (fsym
)->attr
.dimension
5342 || CLASS_DATA (fsym
)->attr
.codimension
))
5344 /* Pass a class array. */
5345 parmse
.use_offset
= 1;
5346 gfc_conv_expr_descriptor (&parmse
, e
);
5348 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5349 allocated on entry, it must be deallocated. */
5350 if (fsym
->attr
.intent
== INTENT_OUT
5351 && CLASS_DATA (fsym
)->attr
.allocatable
)
5356 gfc_init_block (&block
);
5358 ptr
= gfc_class_data_get (ptr
);
5360 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5361 NULL_TREE
, NULL_TREE
,
5363 GFC_CAF_COARRAY_NOCOARRAY
);
5364 gfc_add_expr_to_block (&block
, tmp
);
5365 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5366 void_type_node
, ptr
,
5368 gfc_add_expr_to_block (&block
, tmp
);
5369 gfc_reset_vptr (&block
, e
);
5371 if (fsym
->attr
.optional
5372 && e
->expr_type
== EXPR_VARIABLE
5374 || (e
->ref
->type
== REF_ARRAY
5375 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5376 && e
->symtree
->n
.sym
->attr
.optional
)
5378 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5380 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5381 gfc_finish_block (&block
),
5382 build_empty_stmt (input_location
));
5385 tmp
= gfc_finish_block (&block
);
5387 gfc_add_expr_to_block (&se
->pre
, tmp
);
5390 /* The conversion does not repackage the reference to a class
5391 array - _data descriptor. */
5392 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5393 fsym
->attr
.intent
!= INTENT_IN
5394 && (CLASS_DATA (fsym
)->attr
.class_pointer
5395 || CLASS_DATA (fsym
)->attr
.allocatable
),
5397 && e
->expr_type
== EXPR_VARIABLE
5398 && e
->symtree
->n
.sym
->attr
.optional
,
5399 CLASS_DATA (fsym
)->attr
.class_pointer
5400 || CLASS_DATA (fsym
)->attr
.allocatable
);
5404 /* If the argument is a function call that may not create
5405 a temporary for the result, we have to check that we
5406 can do it, i.e. that there is no alias between this
5407 argument and another one. */
5408 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5414 intent
= fsym
->attr
.intent
;
5416 intent
= INTENT_UNKNOWN
;
5418 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5420 parmse
.force_tmp
= 1;
5422 iarg
= e
->value
.function
.actual
->expr
;
5424 /* Temporary needed if aliasing due to host association. */
5425 if (sym
->attr
.contained
5427 && !sym
->attr
.implicit_pure
5428 && !sym
->attr
.use_assoc
5429 && iarg
->expr_type
== EXPR_VARIABLE
5430 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5431 parmse
.force_tmp
= 1;
5433 /* Ditto within module. */
5434 if (sym
->attr
.use_assoc
5436 && !sym
->attr
.implicit_pure
5437 && iarg
->expr_type
== EXPR_VARIABLE
5438 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5439 parmse
.force_tmp
= 1;
5442 if (e
->expr_type
== EXPR_VARIABLE
5443 && is_subref_array (e
)
5444 && !(fsym
&& fsym
->attr
.pointer
))
5445 /* The actual argument is a component reference to an
5446 array of derived types. In this case, the argument
5447 is converted to a temporary, which is passed and then
5448 written back after the procedure call. */
5449 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5450 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5451 fsym
&& fsym
->attr
.pointer
);
5452 else if (gfc_is_class_array_ref (e
, NULL
)
5453 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5454 /* The actual argument is a component reference to an
5455 array of derived types. In this case, the argument
5456 is converted to a temporary, which is passed and then
5457 written back after the procedure call.
5458 OOP-TODO: Insert code so that if the dynamic type is
5459 the same as the declared type, copy-in/copy-out does
5461 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5462 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5463 fsym
&& fsym
->attr
.pointer
);
5465 else if (gfc_is_alloc_class_array_function (e
)
5466 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5467 /* See previous comment. For function actual argument,
5468 the write out is not needed so the intent is set as
5471 e
->must_finalize
= 1;
5472 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5474 fsym
&& fsym
->attr
.pointer
);
5477 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5480 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5481 allocated on entry, it must be deallocated. */
5482 if (fsym
&& fsym
->attr
.allocatable
5483 && fsym
->attr
.intent
== INTENT_OUT
)
5485 if (fsym
->ts
.type
== BT_DERIVED
5486 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5488 // deallocate the components first
5489 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5490 parmse
.expr
, e
->rank
);
5491 if (tmp
!= NULL_TREE
)
5492 gfc_add_expr_to_block (&se
->pre
, tmp
);
5495 tmp
= build_fold_indirect_ref_loc (input_location
,
5497 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5498 tmp
= gfc_conv_descriptor_data_get (tmp
);
5499 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5500 NULL_TREE
, NULL_TREE
, true,
5502 GFC_CAF_COARRAY_NOCOARRAY
);
5503 if (fsym
->attr
.optional
5504 && e
->expr_type
== EXPR_VARIABLE
5505 && e
->symtree
->n
.sym
->attr
.optional
)
5506 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5508 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5509 tmp
, build_empty_stmt (input_location
));
5510 gfc_add_expr_to_block (&se
->pre
, tmp
);
5515 /* The case with fsym->attr.optional is that of a user subroutine
5516 with an interface indicating an optional argument. When we call
5517 an intrinsic subroutine, however, fsym is NULL, but we might still
5518 have an optional argument, so we proceed to the substitution
5520 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5522 /* If an optional argument is itself an optional dummy argument,
5523 check its presence and substitute a null if absent. This is
5524 only needed when passing an array to an elemental procedure
5525 as then array elements are accessed - or no NULL pointer is
5526 allowed and a "1" or "0" should be passed if not present.
5527 When passing a non-array-descriptor full array to a
5528 non-array-descriptor dummy, no check is needed. For
5529 array-descriptor actual to array-descriptor dummy, see
5530 PR 41911 for why a check has to be inserted.
5531 fsym == NULL is checked as intrinsics required the descriptor
5532 but do not always set fsym. */
5533 if (e
->expr_type
== EXPR_VARIABLE
5534 && e
->symtree
->n
.sym
->attr
.optional
5535 && ((e
->rank
!= 0 && elemental_proc
)
5536 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5540 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5541 || fsym
->as
->type
== AS_ASSUMED_RANK
5542 || fsym
->as
->type
== AS_DEFERRED
))))))
5543 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5544 e
->representation
.length
);
5549 /* Obtain the character length of an assumed character length
5550 length procedure from the typespec. */
5551 if (fsym
->ts
.type
== BT_CHARACTER
5552 && parmse
.string_length
== NULL_TREE
5553 && e
->ts
.type
== BT_PROCEDURE
5554 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5555 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5556 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5558 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5559 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5563 if (fsym
&& need_interface_mapping
&& e
)
5564 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5566 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5567 gfc_add_block_to_block (&post
, &parmse
.post
);
5569 /* Allocated allocatable components of derived types must be
5570 deallocated for non-variable scalars, array arguments to elemental
5571 procedures, and array arguments with descriptor to non-elemental
5572 procedures. As bounds information for descriptorless arrays is no
5573 longer available here, they are dealt with in trans-array.c
5574 (gfc_conv_array_parameter). */
5575 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5576 && e
->ts
.u
.derived
->attr
.alloc_comp
5577 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5578 && !expr_may_alias_variables (e
, elemental_proc
))
5581 /* It is known the e returns a structure type with at least one
5582 allocatable component. When e is a function, ensure that the
5583 function is called once only by using a temporary variable. */
5584 if (!DECL_P (parmse
.expr
))
5585 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5586 parmse
.expr
, &se
->pre
);
5588 if (fsym
&& fsym
->attr
.value
)
5591 tmp
= build_fold_indirect_ref_loc (input_location
,
5594 parm_rank
= e
->rank
;
5602 case (SCALAR_POINTER
):
5603 tmp
= build_fold_indirect_ref_loc (input_location
,
5608 if (e
->expr_type
== EXPR_OP
5609 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5610 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5613 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5614 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5616 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5619 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5621 /* The derived type is passed to gfc_deallocate_alloc_comp.
5622 Therefore, class actuals can handled correctly but derived
5623 types passed to class formals need the _data component. */
5624 tmp
= gfc_class_data_get (tmp
);
5625 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5626 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5629 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5631 gfc_prepend_expr_to_block (&post
, tmp
);
5634 /* Add argument checking of passing an unallocated/NULL actual to
5635 a nonallocatable/nonpointer dummy. */
5637 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5639 symbol_attribute attr
;
5643 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5644 attr
= gfc_expr_attr (e
);
5646 goto end_pointer_check
;
5648 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5649 allocatable to an optional dummy, cf. 12.5.2.12. */
5650 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5651 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5652 goto end_pointer_check
;
5656 /* If the actual argument is an optional pointer/allocatable and
5657 the formal argument takes an nonpointer optional value,
5658 it is invalid to pass a non-present argument on, even
5659 though there is no technical reason for this in gfortran.
5660 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5661 tree present
, null_ptr
, type
;
5663 if (attr
.allocatable
5664 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5665 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5666 "allocated or not present",
5667 e
->symtree
->n
.sym
->name
);
5668 else if (attr
.pointer
5669 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5670 msg
= xasprintf ("Pointer actual argument '%s' is not "
5671 "associated or not present",
5672 e
->symtree
->n
.sym
->name
);
5673 else if (attr
.proc_pointer
5674 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5675 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5676 "associated or not present",
5677 e
->symtree
->n
.sym
->name
);
5679 goto end_pointer_check
;
5681 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5682 type
= TREE_TYPE (present
);
5683 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5684 logical_type_node
, present
,
5686 null_pointer_node
));
5687 type
= TREE_TYPE (parmse
.expr
);
5688 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5689 logical_type_node
, parmse
.expr
,
5691 null_pointer_node
));
5692 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5693 logical_type_node
, present
, null_ptr
);
5697 if (attr
.allocatable
5698 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5699 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5700 "allocated", e
->symtree
->n
.sym
->name
);
5701 else if (attr
.pointer
5702 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5703 msg
= xasprintf ("Pointer actual argument '%s' is not "
5704 "associated", e
->symtree
->n
.sym
->name
);
5705 else if (attr
.proc_pointer
5706 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5707 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5708 "associated", e
->symtree
->n
.sym
->name
);
5710 goto end_pointer_check
;
5714 /* If the argument is passed by value, we need to strip the
5716 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5717 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5719 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5720 logical_type_node
, tmp
,
5721 fold_convert (TREE_TYPE (tmp
),
5722 null_pointer_node
));
5725 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5731 /* Deferred length dummies pass the character length by reference
5732 so that the value can be returned. */
5733 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5735 if (INDIRECT_REF_P (parmse
.string_length
))
5736 /* In chains of functions/procedure calls the string_length already
5737 is a pointer to the variable holding the length. Therefore
5738 remove the deref on call. */
5739 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5742 tmp
= parmse
.string_length
;
5743 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5744 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5745 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5749 /* Character strings are passed as two parameters, a length and a
5750 pointer - except for Bind(c) which only passes the pointer.
5751 An unlimited polymorphic formal argument likewise does not
5753 if (parmse
.string_length
!= NULL_TREE
5754 && !sym
->attr
.is_bind_c
5755 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5756 vec_safe_push (stringargs
, parmse
.string_length
);
5758 /* When calling __copy for character expressions to unlimited
5759 polymorphic entities, the dst argument needs a string length. */
5760 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5761 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5762 && arg
->next
&& arg
->next
->expr
5763 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5764 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5765 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5766 vec_safe_push (stringargs
, parmse
.string_length
);
5768 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5769 pass the token and the offset as additional arguments. */
5770 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5771 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5772 && !fsym
->attr
.allocatable
)
5773 || (fsym
->ts
.type
== BT_CLASS
5774 && CLASS_DATA (fsym
)->attr
.codimension
5775 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5777 /* Token and offset. */
5778 vec_safe_push (stringargs
, null_pointer_node
);
5779 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5780 gcc_assert (fsym
->attr
.optional
);
5782 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5783 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5784 && !fsym
->attr
.allocatable
)
5785 || (fsym
->ts
.type
== BT_CLASS
5786 && CLASS_DATA (fsym
)->attr
.codimension
5787 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5789 tree caf_decl
, caf_type
;
5792 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5793 caf_type
= TREE_TYPE (caf_decl
);
5795 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5796 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5797 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5798 tmp
= gfc_conv_descriptor_token (caf_decl
);
5799 else if (DECL_LANG_SPECIFIC (caf_decl
)
5800 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5801 tmp
= GFC_DECL_TOKEN (caf_decl
);
5804 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5805 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5806 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5809 vec_safe_push (stringargs
, tmp
);
5811 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5812 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5813 offset
= build_int_cst (gfc_array_index_type
, 0);
5814 else if (DECL_LANG_SPECIFIC (caf_decl
)
5815 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5816 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5817 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5818 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5820 offset
= build_int_cst (gfc_array_index_type
, 0);
5822 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5823 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5826 gcc_assert (POINTER_TYPE_P (caf_type
));
5830 tmp2
= fsym
->ts
.type
== BT_CLASS
5831 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5832 if ((fsym
->ts
.type
!= BT_CLASS
5833 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5834 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5835 || (fsym
->ts
.type
== BT_CLASS
5836 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5837 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5839 if (fsym
->ts
.type
== BT_CLASS
)
5840 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5843 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5844 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5846 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5847 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5849 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5850 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5853 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5856 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5857 gfc_array_index_type
,
5858 fold_convert (gfc_array_index_type
, tmp2
),
5859 fold_convert (gfc_array_index_type
, tmp
));
5860 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5861 gfc_array_index_type
, offset
, tmp
);
5863 vec_safe_push (stringargs
, offset
);
5866 vec_safe_push (arglist
, parmse
.expr
);
5868 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5872 else if (sym
->ts
.type
== BT_CLASS
)
5873 ts
= CLASS_DATA (sym
)->ts
;
5877 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5878 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5879 else if (ts
.type
== BT_CHARACTER
)
5881 if (ts
.u
.cl
->length
== NULL
)
5883 /* Assumed character length results are not allowed by 5.1.1.5 of the
5884 standard and are trapped in resolve.c; except in the case of SPREAD
5885 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5886 we take the character length of the first argument for the result.
5887 For dummies, we have to look through the formal argument list for
5888 this function and use the character length found there.*/
5890 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5891 else if (!sym
->attr
.dummy
)
5892 cl
.backend_decl
= (*stringargs
)[0];
5895 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5896 for (; formal
; formal
= formal
->next
)
5897 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5898 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5900 len
= cl
.backend_decl
;
5906 /* Calculate the length of the returned string. */
5907 gfc_init_se (&parmse
, NULL
);
5908 if (need_interface_mapping
)
5909 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5911 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5912 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5913 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5915 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5916 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5917 gfc_charlen_type_node
, tmp
,
5918 build_int_cst (gfc_charlen_type_node
, 0));
5919 cl
.backend_decl
= tmp
;
5922 /* Set up a charlen structure for it. */
5927 len
= cl
.backend_decl
;
5930 byref
= (comp
&& (comp
->attr
.dimension
5931 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5932 || (!comp
&& gfc_return_by_reference (sym
));
5935 if (se
->direct_byref
)
5937 /* Sometimes, too much indirection can be applied; e.g. for
5938 function_result = array_valued_recursive_function. */
5939 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5940 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5941 && GFC_DESCRIPTOR_TYPE_P
5942 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5943 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5946 /* If the lhs of an assignment x = f(..) is allocatable and
5947 f2003 is allowed, we must do the automatic reallocation.
5948 TODO - deal with intrinsics, without using a temporary. */
5949 if (flag_realloc_lhs
5950 && se
->ss
&& se
->ss
->loop_chain
5951 && se
->ss
->loop_chain
->is_alloc_lhs
5952 && !expr
->value
.function
.isym
5953 && sym
->result
->as
!= NULL
)
5955 /* Evaluate the bounds of the result, if known. */
5956 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5959 /* Perform the automatic reallocation. */
5960 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5962 gfc_add_expr_to_block (&se
->pre
, tmp
);
5964 /* Pass the temporary as the first argument. */
5965 result
= info
->descriptor
;
5968 result
= build_fold_indirect_ref_loc (input_location
,
5970 vec_safe_push (retargs
, se
->expr
);
5972 else if (comp
&& comp
->attr
.dimension
)
5974 gcc_assert (se
->loop
&& info
);
5976 /* Set the type of the array. */
5977 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5978 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5980 /* Evaluate the bounds of the result, if known. */
5981 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5983 /* If the lhs of an assignment x = f(..) is allocatable and
5984 f2003 is allowed, we must not generate the function call
5985 here but should just send back the results of the mapping.
5986 This is signalled by the function ss being flagged. */
5987 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5989 gfc_free_interface_mapping (&mapping
);
5990 return has_alternate_specifier
;
5993 /* Create a temporary to store the result. In case the function
5994 returns a pointer, the temporary will be a shallow copy and
5995 mustn't be deallocated. */
5996 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5997 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5998 tmp
, NULL_TREE
, false,
5999 !comp
->attr
.pointer
, callee_alloc
,
6000 &se
->ss
->info
->expr
->where
);
6002 /* Pass the temporary as the first argument. */
6003 result
= info
->descriptor
;
6004 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6005 vec_safe_push (retargs
, tmp
);
6007 else if (!comp
&& sym
->result
->attr
.dimension
)
6009 gcc_assert (se
->loop
&& info
);
6011 /* Set the type of the array. */
6012 tmp
= gfc_typenode_for_spec (&ts
);
6013 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6015 /* Evaluate the bounds of the result, if known. */
6016 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6018 /* If the lhs of an assignment x = f(..) is allocatable and
6019 f2003 is allowed, we must not generate the function call
6020 here but should just send back the results of the mapping.
6021 This is signalled by the function ss being flagged. */
6022 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6024 gfc_free_interface_mapping (&mapping
);
6025 return has_alternate_specifier
;
6028 /* Create a temporary to store the result. In case the function
6029 returns a pointer, the temporary will be a shallow copy and
6030 mustn't be deallocated. */
6031 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6032 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6033 tmp
, NULL_TREE
, false,
6034 !sym
->attr
.pointer
, callee_alloc
,
6035 &se
->ss
->info
->expr
->where
);
6037 /* Pass the temporary as the first argument. */
6038 result
= info
->descriptor
;
6039 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6040 vec_safe_push (retargs
, tmp
);
6042 else if (ts
.type
== BT_CHARACTER
)
6044 /* Pass the string length. */
6045 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6046 type
= build_pointer_type (type
);
6048 /* Emit a DECL_EXPR for the VLA type. */
6049 tmp
= TREE_TYPE (type
);
6051 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6053 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6054 DECL_ARTIFICIAL (tmp
) = 1;
6055 DECL_IGNORED_P (tmp
) = 1;
6056 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6057 TREE_TYPE (tmp
), tmp
);
6058 gfc_add_expr_to_block (&se
->pre
, tmp
);
6061 /* Return an address to a char[0:len-1]* temporary for
6062 character pointers. */
6063 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6064 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6066 var
= gfc_create_var (type
, "pstr");
6068 if ((!comp
&& sym
->attr
.allocatable
)
6069 || (comp
&& comp
->attr
.allocatable
))
6071 gfc_add_modify (&se
->pre
, var
,
6072 fold_convert (TREE_TYPE (var
),
6073 null_pointer_node
));
6074 tmp
= gfc_call_free (var
);
6075 gfc_add_expr_to_block (&se
->post
, tmp
);
6078 /* Provide an address expression for the function arguments. */
6079 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6082 var
= gfc_conv_string_tmp (se
, type
, len
);
6084 vec_safe_push (retargs
, var
);
6088 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6090 type
= gfc_get_complex_type (ts
.kind
);
6091 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6092 vec_safe_push (retargs
, var
);
6095 /* Add the string length to the argument list. */
6096 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6100 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6101 TREE_STATIC (tmp
) = 1;
6102 gfc_add_modify (&se
->pre
, tmp
,
6103 build_int_cst (TREE_TYPE (tmp
), 0));
6104 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6105 vec_safe_push (retargs
, tmp
);
6107 else if (ts
.type
== BT_CHARACTER
)
6108 vec_safe_push (retargs
, len
);
6110 gfc_free_interface_mapping (&mapping
);
6112 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6113 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6114 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6115 vec_safe_reserve (retargs
, arglen
);
6117 /* Add the return arguments. */
6118 vec_safe_splice (retargs
, arglist
);
6120 /* Add the hidden present status for optional+value to the arguments. */
6121 vec_safe_splice (retargs
, optionalargs
);
6123 /* Add the hidden string length parameters to the arguments. */
6124 vec_safe_splice (retargs
, stringargs
);
6126 /* We may want to append extra arguments here. This is used e.g. for
6127 calls to libgfortran_matmul_??, which need extra information. */
6128 vec_safe_splice (retargs
, append_args
);
6132 /* Generate the actual call. */
6133 if (base_object
== NULL_TREE
)
6134 conv_function_val (se
, sym
, expr
);
6136 conv_base_obj_fcn_val (se
, base_object
, expr
);
6138 /* If there are alternate return labels, function type should be
6139 integer. Can't modify the type in place though, since it can be shared
6140 with other functions. For dummy arguments, the typing is done to
6141 this result, even if it has to be repeated for each call. */
6142 if (has_alternate_specifier
6143 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6145 if (!sym
->attr
.dummy
)
6147 TREE_TYPE (sym
->backend_decl
)
6148 = build_function_type (integer_type_node
,
6149 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6150 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6153 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6156 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6157 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6159 /* Allocatable scalar function results must be freed and nullified
6160 after use. This necessitates the creation of a temporary to
6161 hold the result to prevent duplicate calls. */
6162 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6163 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6164 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6166 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6167 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6169 tmp
= gfc_call_free (tmp
);
6170 gfc_add_expr_to_block (&post
, tmp
);
6171 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6174 /* If we have a pointer function, but we don't want a pointer, e.g.
6177 where f is pointer valued, we have to dereference the result. */
6178 if (!se
->want_pointer
&& !byref
6179 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6180 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6181 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6183 /* f2c calling conventions require a scalar default real function to
6184 return a double precision result. Convert this back to default
6185 real. We only care about the cases that can happen in Fortran 77.
6187 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6188 && sym
->ts
.kind
== gfc_default_real_kind
6189 && !sym
->attr
.always_explicit
)
6190 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6192 /* A pure function may still have side-effects - it may modify its
6194 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6196 if (!sym
->attr
.pure
)
6197 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6202 /* Add the function call to the pre chain. There is no expression. */
6203 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6204 se
->expr
= NULL_TREE
;
6206 if (!se
->direct_byref
)
6208 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6210 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6212 /* Check the data pointer hasn't been modified. This would
6213 happen in a function returning a pointer. */
6214 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6215 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6218 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6221 se
->expr
= info
->descriptor
;
6222 /* Bundle in the string length. */
6223 se
->string_length
= len
;
6225 else if (ts
.type
== BT_CHARACTER
)
6227 /* Dereference for character pointer results. */
6228 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6229 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6230 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6234 se
->string_length
= len
;
6238 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6239 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6244 /* Associate the rhs class object's meta-data with the result, when the
6245 result is a temporary. */
6246 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6247 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6248 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6251 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6253 gfc_init_se (&parmse
, NULL
);
6254 parmse
.data_not_needed
= 1;
6255 gfc_conv_expr (&parmse
, class_expr
);
6256 if (!DECL_LANG_SPECIFIC (result
))
6257 gfc_allocate_lang_decl (result
);
6258 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6259 gfc_free_expr (class_expr
);
6260 gcc_assert (parmse
.pre
.head
== NULL_TREE
6261 && parmse
.post
.head
== NULL_TREE
);
6264 /* Follow the function call with the argument post block. */
6267 gfc_add_block_to_block (&se
->pre
, &post
);
6269 /* Transformational functions of derived types with allocatable
6270 components must have the result allocatable components copied when the
6271 argument is actually given. */
6272 arg
= expr
->value
.function
.actual
;
6273 if (result
&& arg
&& expr
->rank
6274 && expr
->value
.function
.isym
6275 && expr
->value
.function
.isym
->transformational
6277 && arg
->expr
->ts
.type
== BT_DERIVED
6278 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6281 /* Copy the allocatable components. We have to use a
6282 temporary here to prevent source allocatable components
6283 from being corrupted. */
6284 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6285 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6286 result
, tmp2
, expr
->rank
, 0);
6287 gfc_add_expr_to_block (&se
->pre
, tmp
);
6288 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6290 gfc_add_expr_to_block (&se
->pre
, tmp
);
6292 /* Finally free the temporary's data field. */
6293 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6294 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6295 NULL_TREE
, NULL_TREE
, true,
6296 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6297 gfc_add_expr_to_block (&se
->pre
, tmp
);
6302 /* For a function with a class array result, save the result as
6303 a temporary, set the info fields needed by the scalarizer and
6304 call the finalization function of the temporary. Note that the
6305 nullification of allocatable components needed by the result
6306 is done in gfc_trans_assignment_1. */
6307 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6308 && se
->ss
&& se
->ss
->loop
)
6309 || gfc_is_alloc_class_scalar_function (expr
))
6310 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6311 && expr
->must_finalize
)
6316 if (se
->ss
&& se
->ss
->loop
)
6318 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6319 tmp
= gfc_class_data_get (se
->expr
);
6320 info
->descriptor
= tmp
;
6321 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6322 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6323 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6325 tree dim
= gfc_rank_cst
[n
];
6326 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6327 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6332 /* TODO Eliminate the doubling of temporaries. This
6333 one is necessary to ensure no memory leakage. */
6334 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6335 tmp
= gfc_class_data_get (se
->expr
);
6336 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6337 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6340 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6341 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6344 fold_convert (TREE_TYPE (final_fndecl
),
6345 null_pointer_node
));
6346 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6348 tmp
= build_call_expr_loc (input_location
,
6350 gfc_build_addr_expr (NULL
, tmp
),
6351 gfc_class_vtab_size_get (se
->expr
),
6352 boolean_false_node
);
6353 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6354 void_type_node
, is_final
, tmp
,
6355 build_empty_stmt (input_location
));
6357 if (se
->ss
&& se
->ss
->loop
)
6359 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6360 tmp
= gfc_call_free (info
->data
);
6361 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6365 gfc_add_expr_to_block (&se
->post
, tmp
);
6366 tmp
= gfc_class_data_get (se
->expr
);
6367 tmp
= gfc_call_free (tmp
);
6368 gfc_add_expr_to_block (&se
->post
, tmp
);
6370 expr
->must_finalize
= 0;
6373 gfc_add_block_to_block (&se
->post
, &post
);
6376 return has_alternate_specifier
;
6380 /* Fill a character string with spaces. */
6383 fill_with_spaces (tree start
, tree type
, tree size
)
6385 stmtblock_t block
, loop
;
6386 tree i
, el
, exit_label
, cond
, tmp
;
6388 /* For a simple char type, we can call memset(). */
6389 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6390 return build_call_expr_loc (input_location
,
6391 builtin_decl_explicit (BUILT_IN_MEMSET
),
6393 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6394 lang_hooks
.to_target_charset (' ')),
6397 /* Otherwise, we use a loop:
6398 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6402 /* Initialize variables. */
6403 gfc_init_block (&block
);
6404 i
= gfc_create_var (sizetype
, "i");
6405 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6406 el
= gfc_create_var (build_pointer_type (type
), "el");
6407 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6408 exit_label
= gfc_build_label_decl (NULL_TREE
);
6409 TREE_USED (exit_label
) = 1;
6413 gfc_init_block (&loop
);
6415 /* Exit condition. */
6416 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6417 build_zero_cst (sizetype
));
6418 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6419 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6420 build_empty_stmt (input_location
));
6421 gfc_add_expr_to_block (&loop
, tmp
);
6424 gfc_add_modify (&loop
,
6425 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6426 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6428 /* Increment loop variables. */
6429 gfc_add_modify (&loop
, i
,
6430 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6431 TYPE_SIZE_UNIT (type
)));
6432 gfc_add_modify (&loop
, el
,
6433 fold_build_pointer_plus_loc (input_location
,
6434 el
, TYPE_SIZE_UNIT (type
)));
6436 /* Making the loop... actually loop! */
6437 tmp
= gfc_finish_block (&loop
);
6438 tmp
= build1_v (LOOP_EXPR
, tmp
);
6439 gfc_add_expr_to_block (&block
, tmp
);
6441 /* The exit label. */
6442 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6443 gfc_add_expr_to_block (&block
, tmp
);
6446 return gfc_finish_block (&block
);
6450 /* Generate code to copy a string. */
6453 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6454 int dkind
, tree slength
, tree src
, int skind
)
6456 tree tmp
, dlen
, slen
;
6465 stmtblock_t tempblock
;
6467 gcc_assert (dkind
== skind
);
6469 if (slength
!= NULL_TREE
)
6471 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6472 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6476 slen
= build_int_cst (size_type_node
, 1);
6480 if (dlength
!= NULL_TREE
)
6482 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6483 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6487 dlen
= build_int_cst (size_type_node
, 1);
6491 /* Assign directly if the types are compatible. */
6492 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6493 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6495 gfc_add_modify (block
, dsc
, ssc
);
6499 /* The string copy algorithm below generates code like
6502 memmove (dest, src, min(dlen, slen));
6504 memset(&dest[slen], ' ', dlen - slen);
6508 /* Do nothing if the destination length is zero. */
6509 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6510 build_int_cst (size_type_node
, 0));
6512 /* For non-default character kinds, we have to multiply the string
6513 length by the base type size. */
6514 chartype
= gfc_get_char_type (dkind
);
6515 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6516 fold_convert (size_type_node
, slen
),
6517 fold_convert (size_type_node
,
6518 TYPE_SIZE_UNIT (chartype
)));
6519 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6520 fold_convert (size_type_node
, dlen
),
6521 fold_convert (size_type_node
,
6522 TYPE_SIZE_UNIT (chartype
)));
6524 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6525 dest
= fold_convert (pvoid_type_node
, dest
);
6527 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6529 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6530 src
= fold_convert (pvoid_type_node
, src
);
6532 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6534 /* First do the memmove. */
6535 tmp2
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (dlen
), dlen
,
6537 tmp2
= build_call_expr_loc (input_location
,
6538 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6539 3, dest
, src
, tmp2
);
6540 stmtblock_t tmpblock2
;
6541 gfc_init_block (&tmpblock2
);
6542 gfc_add_expr_to_block (&tmpblock2
, tmp2
);
6544 /* If the destination is longer, fill the end with spaces. */
6545 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6548 /* Wstringop-overflow appears at -O3 even though this warning is not
6549 explicitly available in fortran nor can it be switched off. If the
6550 source length is a constant, its negative appears as a very large
6551 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6552 the result of the MINUS_EXPR suppresses this spurious warning. */
6553 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6554 TREE_TYPE(dlen
), dlen
, slen
);
6555 if (slength
&& TREE_CONSTANT (slength
))
6556 tmp
= gfc_evaluate_now (tmp
, block
);
6558 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6559 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6561 gfc_init_block (&tempblock
);
6562 gfc_add_expr_to_block (&tempblock
, tmp4
);
6563 tmp3
= gfc_finish_block (&tempblock
);
6565 /* The whole copy_string function is there. */
6566 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6567 tmp3
, build_empty_stmt (input_location
));
6568 gfc_add_expr_to_block (&tmpblock2
, tmp
);
6569 tmp
= gfc_finish_block (&tmpblock2
);
6570 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6571 build_empty_stmt (input_location
));
6572 gfc_add_expr_to_block (block
, tmp
);
6576 /* Translate a statement function.
6577 The value of a statement function reference is obtained by evaluating the
6578 expression using the values of the actual arguments for the values of the
6579 corresponding dummy arguments. */
6582 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6586 gfc_formal_arglist
*fargs
;
6587 gfc_actual_arglist
*args
;
6590 gfc_saved_var
*saved_vars
;
6596 sym
= expr
->symtree
->n
.sym
;
6597 args
= expr
->value
.function
.actual
;
6598 gfc_init_se (&lse
, NULL
);
6599 gfc_init_se (&rse
, NULL
);
6602 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6604 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6605 temp_vars
= XCNEWVEC (tree
, n
);
6607 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6608 fargs
= fargs
->next
, n
++)
6610 /* Each dummy shall be specified, explicitly or implicitly, to be
6612 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6615 if (fsym
->ts
.type
== BT_CHARACTER
)
6617 /* Copy string arguments. */
6620 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6621 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6623 /* Create a temporary to hold the value. */
6624 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6625 fsym
->ts
.u
.cl
->backend_decl
6626 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6628 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6629 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6631 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6633 gfc_conv_expr (&rse
, args
->expr
);
6634 gfc_conv_string_parameter (&rse
);
6635 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6636 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6638 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6639 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6640 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6641 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6645 /* For everything else, just evaluate the expression. */
6647 /* Create a temporary to hold the value. */
6648 type
= gfc_typenode_for_spec (&fsym
->ts
);
6649 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6651 gfc_conv_expr (&lse
, args
->expr
);
6653 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6654 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6655 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6661 /* Use the temporary variables in place of the real ones. */
6662 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6663 fargs
= fargs
->next
, n
++)
6664 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6666 gfc_conv_expr (se
, sym
->value
);
6668 if (sym
->ts
.type
== BT_CHARACTER
)
6670 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6672 /* Force the expression to the correct length. */
6673 if (!INTEGER_CST_P (se
->string_length
)
6674 || tree_int_cst_lt (se
->string_length
,
6675 sym
->ts
.u
.cl
->backend_decl
))
6677 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6678 tmp
= gfc_create_var (type
, sym
->name
);
6679 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6680 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6681 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6685 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6688 /* Restore the original variables. */
6689 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6690 fargs
= fargs
->next
, n
++)
6691 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6697 /* Translate a function expression. */
6700 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6704 if (expr
->value
.function
.isym
)
6706 gfc_conv_intrinsic_function (se
, expr
);
6710 /* expr.value.function.esym is the resolved (specific) function symbol for
6711 most functions. However this isn't set for dummy procedures. */
6712 sym
= expr
->value
.function
.esym
;
6714 sym
= expr
->symtree
->n
.sym
;
6716 /* The IEEE_ARITHMETIC functions are caught here. */
6717 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6718 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6721 /* We distinguish statement functions from general functions to improve
6722 runtime performance. */
6723 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6725 gfc_conv_statement_function (se
, expr
);
6729 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6734 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6737 is_zero_initializer_p (gfc_expr
* expr
)
6739 if (expr
->expr_type
!= EXPR_CONSTANT
)
6742 /* We ignore constants with prescribed memory representations for now. */
6743 if (expr
->representation
.string
)
6746 switch (expr
->ts
.type
)
6749 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6752 return mpfr_zero_p (expr
->value
.real
)
6753 && MPFR_SIGN (expr
->value
.real
) >= 0;
6756 return expr
->value
.logical
== 0;
6759 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6760 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6761 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6762 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6772 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6777 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6778 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6780 gfc_conv_tmp_array_ref (se
);
6784 /* Build a static initializer. EXPR is the expression for the initial value.
6785 The other parameters describe the variable of the component being
6786 initialized. EXPR may be null. */
6789 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6790 bool array
, bool pointer
, bool procptr
)
6794 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6795 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6796 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6797 return build_constructor (type
, NULL
);
6799 if (!(expr
|| pointer
|| procptr
))
6802 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6803 (these are the only two iso_c_binding derived types that can be
6804 used as initialization expressions). If so, we need to modify
6805 the 'expr' to be that for a (void *). */
6806 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6807 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6809 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6811 /* The derived symbol has already been converted to a (void *). Use
6813 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6814 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6816 gfc_init_se (&se
, NULL
);
6817 gfc_conv_constant (&se
, expr
);
6818 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6822 if (array
&& !procptr
)
6825 /* Arrays need special handling. */
6827 ctor
= gfc_build_null_descriptor (type
);
6828 /* Special case assigning an array to zero. */
6829 else if (is_zero_initializer_p (expr
))
6830 ctor
= build_constructor (type
, NULL
);
6832 ctor
= gfc_conv_array_initializer (type
, expr
);
6833 TREE_STATIC (ctor
) = 1;
6836 else if (pointer
|| procptr
)
6838 if (ts
->type
== BT_CLASS
&& !procptr
)
6840 gfc_init_se (&se
, NULL
);
6841 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6842 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6843 TREE_STATIC (se
.expr
) = 1;
6846 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6847 return fold_convert (type
, null_pointer_node
);
6850 gfc_init_se (&se
, NULL
);
6851 se
.want_pointer
= 1;
6852 gfc_conv_expr (&se
, expr
);
6853 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6863 gfc_init_se (&se
, NULL
);
6864 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6865 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6867 gfc_conv_structure (&se
, expr
, 1);
6868 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6869 TREE_STATIC (se
.expr
) = 1;
6874 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6875 TREE_STATIC (ctor
) = 1;
6880 gfc_init_se (&se
, NULL
);
6881 gfc_conv_constant (&se
, expr
);
6882 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6889 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6895 gfc_array_info
*lss_array
;
6902 gfc_start_block (&block
);
6904 /* Initialize the scalarizer. */
6905 gfc_init_loopinfo (&loop
);
6907 gfc_init_se (&lse
, NULL
);
6908 gfc_init_se (&rse
, NULL
);
6911 rss
= gfc_walk_expr (expr
);
6912 if (rss
== gfc_ss_terminator
)
6913 /* The rhs is scalar. Add a ss for the expression. */
6914 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6916 /* Create a SS for the destination. */
6917 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6919 lss_array
= &lss
->info
->data
.array
;
6920 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6921 lss_array
->descriptor
= dest
;
6922 lss_array
->data
= gfc_conv_array_data (dest
);
6923 lss_array
->offset
= gfc_conv_array_offset (dest
);
6924 for (n
= 0; n
< cm
->as
->rank
; n
++)
6926 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6927 lss_array
->stride
[n
] = gfc_index_one_node
;
6929 mpz_init (lss_array
->shape
[n
]);
6930 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6931 cm
->as
->lower
[n
]->value
.integer
);
6932 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6935 /* Associate the SS with the loop. */
6936 gfc_add_ss_to_loop (&loop
, lss
);
6937 gfc_add_ss_to_loop (&loop
, rss
);
6939 /* Calculate the bounds of the scalarization. */
6940 gfc_conv_ss_startstride (&loop
);
6942 /* Setup the scalarizing loops. */
6943 gfc_conv_loop_setup (&loop
, &expr
->where
);
6945 /* Setup the gfc_se structures. */
6946 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6947 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6950 gfc_mark_ss_chain_used (rss
, 1);
6952 gfc_mark_ss_chain_used (lss
, 1);
6954 /* Start the scalarized loop body. */
6955 gfc_start_scalarized_body (&loop
, &body
);
6957 gfc_conv_tmp_array_ref (&lse
);
6958 if (cm
->ts
.type
== BT_CHARACTER
)
6959 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6961 gfc_conv_expr (&rse
, expr
);
6963 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6964 gfc_add_expr_to_block (&body
, tmp
);
6966 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6968 /* Generate the copying loops. */
6969 gfc_trans_scalarizing_loops (&loop
, &body
);
6971 /* Wrap the whole thing up. */
6972 gfc_add_block_to_block (&block
, &loop
.pre
);
6973 gfc_add_block_to_block (&block
, &loop
.post
);
6975 gcc_assert (lss_array
->shape
!= NULL
);
6976 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6977 gfc_cleanup_loop (&loop
);
6979 return gfc_finish_block (&block
);
6984 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6994 gfc_expr
*arg
= NULL
;
6996 gfc_start_block (&block
);
6997 gfc_init_se (&se
, NULL
);
6999 /* Get the descriptor for the expressions. */
7000 se
.want_pointer
= 0;
7001 gfc_conv_expr_descriptor (&se
, expr
);
7002 gfc_add_block_to_block (&block
, &se
.pre
);
7003 gfc_add_modify (&block
, dest
, se
.expr
);
7005 /* Deal with arrays of derived types with allocatable components. */
7006 if (gfc_bt_struct (cm
->ts
.type
)
7007 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7008 // TODO: Fix caf_mode
7009 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7012 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7013 && CLASS_DATA(cm
)->attr
.allocatable
)
7015 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7016 // TODO: Fix caf_mode
7017 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7022 tmp
= TREE_TYPE (dest
);
7023 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7024 tmp
, expr
->rank
, NULL_TREE
);
7028 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7029 TREE_TYPE(cm
->backend_decl
),
7030 cm
->as
->rank
, NULL_TREE
);
7032 gfc_add_expr_to_block (&block
, tmp
);
7033 gfc_add_block_to_block (&block
, &se
.post
);
7035 if (expr
->expr_type
!= EXPR_VARIABLE
)
7036 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7039 /* We need to know if the argument of a conversion function is a
7040 variable, so that the correct lower bound can be used. */
7041 if (expr
->expr_type
== EXPR_FUNCTION
7042 && expr
->value
.function
.isym
7043 && expr
->value
.function
.isym
->conversion
7044 && expr
->value
.function
.actual
->expr
7045 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7046 arg
= expr
->value
.function
.actual
->expr
;
7048 /* Obtain the array spec of full array references. */
7050 as
= gfc_get_full_arrayspec_from_expr (arg
);
7052 as
= gfc_get_full_arrayspec_from_expr (expr
);
7054 /* Shift the lbound and ubound of temporaries to being unity,
7055 rather than zero, based. Always calculate the offset. */
7056 offset
= gfc_conv_descriptor_offset_get (dest
);
7057 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7058 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7060 for (n
= 0; n
< expr
->rank
; n
++)
7065 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7066 TODO It looks as if gfc_conv_expr_descriptor should return
7067 the correct bounds and that the following should not be
7068 necessary. This would simplify gfc_conv_intrinsic_bound
7070 if (as
&& as
->lower
[n
])
7073 gfc_init_se (&lbse
, NULL
);
7074 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7075 gfc_add_block_to_block (&block
, &lbse
.pre
);
7076 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7080 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7081 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7085 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7088 lbound
= gfc_index_one_node
;
7090 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7092 /* Shift the bounds and set the offset accordingly. */
7093 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7094 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7095 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7096 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7098 gfc_conv_descriptor_ubound_set (&block
, dest
,
7099 gfc_rank_cst
[n
], tmp
);
7100 gfc_conv_descriptor_lbound_set (&block
, dest
,
7101 gfc_rank_cst
[n
], lbound
);
7103 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7104 gfc_conv_descriptor_lbound_get (dest
,
7106 gfc_conv_descriptor_stride_get (dest
,
7108 gfc_add_modify (&block
, tmp2
, tmp
);
7109 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7111 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7116 /* If a conversion expression has a null data pointer
7117 argument, nullify the allocatable component. */
7121 if (arg
->symtree
->n
.sym
->attr
.allocatable
7122 || arg
->symtree
->n
.sym
->attr
.pointer
)
7124 non_null_expr
= gfc_finish_block (&block
);
7125 gfc_start_block (&block
);
7126 gfc_conv_descriptor_data_set (&block
, dest
,
7128 null_expr
= gfc_finish_block (&block
);
7129 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7130 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7131 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7132 return build3_v (COND_EXPR
, tmp
,
7133 null_expr
, non_null_expr
);
7137 return gfc_finish_block (&block
);
7141 /* Allocate or reallocate scalar component, as necessary. */
7144 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7154 tree lhs_cl_size
= NULL_TREE
;
7159 if (!expr2
|| expr2
->rank
)
7162 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7164 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7166 char name
[GFC_MAX_SYMBOL_LEN
+9];
7167 gfc_component
*strlen
;
7168 /* Use the rhs string length and the lhs element size. */
7169 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7170 if (!expr2
->ts
.u
.cl
->backend_decl
)
7172 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7173 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7176 size
= expr2
->ts
.u
.cl
->backend_decl
;
7178 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7180 sprintf (name
, "_%s_length", cm
->name
);
7181 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7182 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7183 gfc_charlen_type_node
,
7184 TREE_OPERAND (comp
, 0),
7185 strlen
->backend_decl
, NULL_TREE
);
7187 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7188 tmp
= TYPE_SIZE_UNIT (tmp
);
7189 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7190 TREE_TYPE (tmp
), tmp
,
7191 fold_convert (TREE_TYPE (tmp
), size
));
7193 else if (cm
->ts
.type
== BT_CLASS
)
7195 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7196 if (expr2
->ts
.type
== BT_DERIVED
)
7198 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7199 size
= TYPE_SIZE_UNIT (tmp
);
7205 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7206 gfc_add_vptr_component (e2vtab
);
7207 gfc_add_size_component (e2vtab
);
7208 gfc_init_se (&se
, NULL
);
7209 gfc_conv_expr (&se
, e2vtab
);
7210 gfc_add_block_to_block (block
, &se
.pre
);
7211 size
= fold_convert (size_type_node
, se
.expr
);
7212 gfc_free_expr (e2vtab
);
7214 size_in_bytes
= size
;
7218 /* Otherwise use the length in bytes of the rhs. */
7219 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7220 size_in_bytes
= size
;
7223 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7224 size_in_bytes
, size_one_node
);
7226 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7228 tmp
= build_call_expr_loc (input_location
,
7229 builtin_decl_explicit (BUILT_IN_CALLOC
),
7230 2, build_one_cst (size_type_node
),
7232 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7233 gfc_add_modify (block
, comp
, tmp
);
7237 tmp
= build_call_expr_loc (input_location
,
7238 builtin_decl_explicit (BUILT_IN_MALLOC
),
7240 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7241 ptr
= gfc_class_data_get (comp
);
7244 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7245 gfc_add_modify (block
, ptr
, tmp
);
7248 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7249 /* Update the lhs character length. */
7250 gfc_add_modify (block
, lhs_cl_size
, size
);
7254 /* Assign a single component of a derived type constructor. */
7257 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7258 gfc_symbol
*sym
, bool init
)
7266 gfc_start_block (&block
);
7268 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7270 /* Only care about pointers here, not about allocatables. */
7271 gfc_init_se (&se
, NULL
);
7272 /* Pointer component. */
7273 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7274 && !cm
->attr
.proc_pointer
)
7276 /* Array pointer. */
7277 if (expr
->expr_type
== EXPR_NULL
)
7278 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7281 se
.direct_byref
= 1;
7283 gfc_conv_expr_descriptor (&se
, expr
);
7284 gfc_add_block_to_block (&block
, &se
.pre
);
7285 gfc_add_block_to_block (&block
, &se
.post
);
7290 /* Scalar pointers. */
7291 se
.want_pointer
= 1;
7292 gfc_conv_expr (&se
, expr
);
7293 gfc_add_block_to_block (&block
, &se
.pre
);
7295 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7296 && expr
->symtree
->n
.sym
->attr
.dummy
)
7297 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7299 gfc_add_modify (&block
, dest
,
7300 fold_convert (TREE_TYPE (dest
), se
.expr
));
7301 gfc_add_block_to_block (&block
, &se
.post
);
7304 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7306 /* NULL initialization for CLASS components. */
7307 tmp
= gfc_trans_structure_assign (dest
,
7308 gfc_class_initializer (&cm
->ts
, expr
),
7310 gfc_add_expr_to_block (&block
, tmp
);
7312 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7313 && !cm
->attr
.proc_pointer
)
7315 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7316 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7317 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7319 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7320 gfc_add_expr_to_block (&block
, tmp
);
7324 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7325 gfc_add_expr_to_block (&block
, tmp
);
7328 else if (cm
->ts
.type
== BT_CLASS
7329 && CLASS_DATA (cm
)->attr
.dimension
7330 && CLASS_DATA (cm
)->attr
.allocatable
7331 && expr
->ts
.type
== BT_DERIVED
)
7333 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7334 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7335 tmp
= gfc_class_vptr_get (dest
);
7336 gfc_add_modify (&block
, tmp
,
7337 fold_convert (TREE_TYPE (tmp
), vtab
));
7338 tmp
= gfc_class_data_get (dest
);
7339 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7340 gfc_add_expr_to_block (&block
, tmp
);
7342 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7344 /* NULL initialization for allocatable components. */
7345 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7346 null_pointer_node
));
7348 else if (init
&& (cm
->attr
.allocatable
7349 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7350 && expr
->ts
.type
!= BT_CLASS
)))
7352 /* Take care about non-array allocatable components here. The alloc_*
7353 routine below is motivated by the alloc_scalar_allocatable_for_
7354 assignment() routine, but with the realloc portions removed and
7356 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7361 /* The remainder of these instructions follow the if (cm->attr.pointer)
7362 if (!cm->attr.dimension) part above. */
7363 gfc_init_se (&se
, NULL
);
7364 gfc_conv_expr (&se
, expr
);
7365 gfc_add_block_to_block (&block
, &se
.pre
);
7367 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7368 && expr
->symtree
->n
.sym
->attr
.dummy
)
7369 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7371 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7373 tmp
= gfc_class_data_get (dest
);
7374 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7375 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7376 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7377 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7378 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7381 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7383 /* For deferred strings insert a memcpy. */
7384 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7387 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7388 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7390 : expr
->ts
.u
.cl
->backend_decl
);
7391 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7392 gfc_add_expr_to_block (&block
, tmp
);
7395 gfc_add_modify (&block
, tmp
,
7396 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7397 gfc_add_block_to_block (&block
, &se
.post
);
7399 else if (expr
->ts
.type
== BT_UNION
)
7402 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7403 /* We mark that the entire union should be initialized with a contrived
7404 EXPR_NULL expression at the beginning. */
7405 if (c
!= NULL
&& c
->n
.component
== NULL
7406 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7408 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7409 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7410 gfc_add_expr_to_block (&block
, tmp
);
7411 c
= gfc_constructor_next (c
);
7413 /* The following constructor expression, if any, represents a specific
7414 map intializer, as given by the user. */
7415 if (c
!= NULL
&& c
->expr
!= NULL
)
7417 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7418 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7419 gfc_add_expr_to_block (&block
, tmp
);
7422 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7424 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7426 tree dealloc
= NULL_TREE
;
7427 gfc_init_se (&se
, NULL
);
7428 gfc_conv_expr (&se
, expr
);
7429 gfc_add_block_to_block (&block
, &se
.pre
);
7430 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7431 expression in a temporary variable and deallocate the allocatable
7432 components. Then we can the copy the expression to the result. */
7433 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7434 && expr
->expr_type
!= EXPR_VARIABLE
)
7436 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7437 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7440 gfc_add_modify (&block
, dest
,
7441 fold_convert (TREE_TYPE (dest
), se
.expr
));
7442 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7443 && expr
->expr_type
!= EXPR_NULL
)
7445 // TODO: Fix caf_mode
7446 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7447 dest
, expr
->rank
, 0);
7448 gfc_add_expr_to_block (&block
, tmp
);
7449 if (dealloc
!= NULL_TREE
)
7450 gfc_add_expr_to_block (&block
, dealloc
);
7452 gfc_add_block_to_block (&block
, &se
.post
);
7456 /* Nested constructors. */
7457 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7458 gfc_add_expr_to_block (&block
, tmp
);
7461 else if (gfc_deferred_strlen (cm
, &tmp
))
7465 gcc_assert (strlen
);
7466 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7468 TREE_OPERAND (dest
, 0),
7471 if (expr
->expr_type
== EXPR_NULL
)
7473 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7474 gfc_add_modify (&block
, dest
, tmp
);
7475 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7476 gfc_add_modify (&block
, strlen
, tmp
);
7481 gfc_init_se (&se
, NULL
);
7482 gfc_conv_expr (&se
, expr
);
7483 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7484 tmp
= build_call_expr_loc (input_location
,
7485 builtin_decl_explicit (BUILT_IN_MALLOC
),
7487 gfc_add_modify (&block
, dest
,
7488 fold_convert (TREE_TYPE (dest
), tmp
));
7489 gfc_add_modify (&block
, strlen
, se
.string_length
);
7490 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7491 gfc_add_expr_to_block (&block
, tmp
);
7494 else if (!cm
->attr
.artificial
)
7496 /* Scalar component (excluding deferred parameters). */
7497 gfc_init_se (&se
, NULL
);
7498 gfc_init_se (&lse
, NULL
);
7500 gfc_conv_expr (&se
, expr
);
7501 if (cm
->ts
.type
== BT_CHARACTER
)
7502 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7504 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7505 gfc_add_expr_to_block (&block
, tmp
);
7507 return gfc_finish_block (&block
);
7510 /* Assign a derived type constructor to a variable. */
7513 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7522 gfc_start_block (&block
);
7523 cm
= expr
->ts
.u
.derived
->components
;
7525 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7526 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7527 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7531 gfc_init_se (&se
, NULL
);
7532 gfc_init_se (&lse
, NULL
);
7533 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7535 gfc_add_modify (&block
, lse
.expr
,
7536 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7538 return gfc_finish_block (&block
);
7542 gfc_init_se (&se
, NULL
);
7544 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7545 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7547 /* Skip absent members in default initializers. */
7548 if (!c
->expr
&& !cm
->attr
.allocatable
)
7551 /* Register the component with the caf-lib before it is initialized.
7552 Register only allocatable components, that are not coarray'ed
7553 components (%comp[*]). Only register when the constructor is not the
7555 if (coarray
&& !cm
->attr
.codimension
7556 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7557 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7559 tree token
, desc
, size
;
7560 bool is_array
= cm
->ts
.type
== BT_CLASS
7561 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7563 field
= cm
->backend_decl
;
7564 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7565 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7566 if (cm
->ts
.type
== BT_CLASS
)
7567 field
= gfc_class_data_get (field
);
7569 token
= is_array
? gfc_conv_descriptor_token (field
)
7570 : fold_build3_loc (input_location
, COMPONENT_REF
,
7571 TREE_TYPE (cm
->caf_token
), dest
,
7572 cm
->caf_token
, NULL_TREE
);
7576 /* The _caf_register routine looks at the rank of the array
7577 descriptor to decide whether the data registered is an array
7579 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7581 /* When the rank is not known just set a positive rank, which
7582 suffices to recognize the data as array. */
7585 size
= integer_zero_node
;
7587 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7588 build_int_cst (gfc_array_index_type
, rank
));
7592 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
7593 cm
->ts
.type
== BT_CLASS
7594 ? CLASS_DATA (cm
)->attr
7596 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7598 gfc_add_block_to_block (&block
, &se
.pre
);
7599 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7600 7, size
, build_int_cst (
7602 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7603 gfc_build_addr_expr (pvoid_type_node
,
7605 gfc_build_addr_expr (NULL_TREE
, desc
),
7606 null_pointer_node
, null_pointer_node
,
7608 gfc_add_expr_to_block (&block
, tmp
);
7610 field
= cm
->backend_decl
;
7611 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7612 dest
, field
, NULL_TREE
);
7615 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7616 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7621 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7622 expr
->ts
.u
.derived
, init
);
7623 gfc_add_expr_to_block (&block
, tmp
);
7625 return gfc_finish_block (&block
);
7629 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7630 gfc_component
*un
, gfc_expr
*init
)
7632 gfc_constructor
*ctor
;
7634 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7637 ctor
= gfc_constructor_first (init
->value
.constructor
);
7639 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7642 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7644 /* If we have an 'initialize all' constructor, do it first. */
7645 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7647 tree union_type
= TREE_TYPE (un
->backend_decl
);
7648 tree val
= build_constructor (union_type
, NULL
);
7649 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7650 ctor
= gfc_constructor_next (ctor
);
7653 /* Add the map initializer on top. */
7654 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7656 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7657 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7658 TREE_TYPE (un
->backend_decl
),
7659 un
->attr
.dimension
, un
->attr
.pointer
,
7660 un
->attr
.proc_pointer
);
7661 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7665 /* Build an expression for a constructor. If init is nonzero then
7666 this is part of a static variable initializer. */
7669 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7676 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7678 gcc_assert (se
->ss
== NULL
);
7679 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7680 type
= gfc_typenode_for_spec (&expr
->ts
);
7684 /* Create a temporary variable and fill it in. */
7685 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7686 /* The symtree in expr is NULL, if the code to generate is for
7687 initializing the static members only. */
7688 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7690 gfc_add_expr_to_block (&se
->pre
, tmp
);
7694 cm
= expr
->ts
.u
.derived
->components
;
7696 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7697 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7699 /* Skip absent members in default initializers and allocatable
7700 components. Although the latter have a default initializer
7701 of EXPR_NULL,... by default, the static nullify is not needed
7702 since this is done every time we come into scope. */
7703 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7706 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7707 && strcmp (cm
->name
, "_extends") == 0
7708 && cm
->initializer
->symtree
)
7712 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7713 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7714 vtab
= unshare_expr_without_location (vtab
);
7715 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7717 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7719 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7720 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7721 fold_convert (TREE_TYPE (cm
->backend_decl
),
7724 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7725 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7726 fold_convert (TREE_TYPE (cm
->backend_decl
),
7727 integer_zero_node
));
7728 else if (cm
->ts
.type
== BT_UNION
)
7729 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7732 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7733 TREE_TYPE (cm
->backend_decl
),
7734 cm
->attr
.dimension
, cm
->attr
.pointer
,
7735 cm
->attr
.proc_pointer
);
7736 val
= unshare_expr_without_location (val
);
7738 /* Append it to the constructor list. */
7739 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7743 se
->expr
= build_constructor (type
, v
);
7745 TREE_CONSTANT (se
->expr
) = 1;
7749 /* Translate a substring expression. */
7752 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7758 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7760 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7761 expr
->value
.character
.length
,
7762 expr
->value
.character
.string
);
7764 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7765 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7768 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7772 /* Entry point for expression translation. Evaluates a scalar quantity.
7773 EXPR is the expression to be translated, and SE is the state structure if
7774 called from within the scalarized. */
7777 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7782 if (ss
&& ss
->info
->expr
== expr
7783 && (ss
->info
->type
== GFC_SS_SCALAR
7784 || ss
->info
->type
== GFC_SS_REFERENCE
))
7786 gfc_ss_info
*ss_info
;
7789 /* Substitute a scalar expression evaluated outside the scalarization
7791 se
->expr
= ss_info
->data
.scalar
.value
;
7792 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7793 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7795 se
->string_length
= ss_info
->string_length
;
7796 gfc_advance_se_ss_chain (se
);
7800 /* We need to convert the expressions for the iso_c_binding derived types.
7801 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7802 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7803 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7804 updated to be an integer with a kind equal to the size of a (void *). */
7805 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7806 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7808 if (expr
->expr_type
== EXPR_VARIABLE
7809 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7810 || expr
->symtree
->n
.sym
->intmod_sym_id
7811 == ISOCBINDING_NULL_FUNPTR
))
7813 /* Set expr_type to EXPR_NULL, which will result in
7814 null_pointer_node being used below. */
7815 expr
->expr_type
= EXPR_NULL
;
7819 /* Update the type/kind of the expression to be what the new
7820 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7821 expr
->ts
.type
= BT_INTEGER
;
7822 expr
->ts
.f90_type
= BT_VOID
;
7823 expr
->ts
.kind
= gfc_index_integer_kind
;
7827 gfc_fix_class_refs (expr
);
7829 switch (expr
->expr_type
)
7832 gfc_conv_expr_op (se
, expr
);
7836 gfc_conv_function_expr (se
, expr
);
7840 gfc_conv_constant (se
, expr
);
7844 gfc_conv_variable (se
, expr
);
7848 se
->expr
= null_pointer_node
;
7851 case EXPR_SUBSTRING
:
7852 gfc_conv_substring_expr (se
, expr
);
7855 case EXPR_STRUCTURE
:
7856 gfc_conv_structure (se
, expr
, 0);
7860 gfc_conv_array_constructor_expr (se
, expr
);
7869 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7870 of an assignment. */
7872 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7874 gfc_conv_expr (se
, expr
);
7875 /* All numeric lvalues should have empty post chains. If not we need to
7876 figure out a way of rewriting an lvalue so that it has no post chain. */
7877 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7880 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7881 numeric expressions. Used for scalar values where inserting cleanup code
7884 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7888 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7889 gfc_conv_expr (se
, expr
);
7892 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7893 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7895 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7899 /* Helper to translate an expression and convert it to a particular type. */
7901 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7903 gfc_conv_expr_val (se
, expr
);
7904 se
->expr
= convert (type
, se
->expr
);
7908 /* Converts an expression so that it can be passed by reference. Scalar
7912 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7918 if (ss
&& ss
->info
->expr
== expr
7919 && ss
->info
->type
== GFC_SS_REFERENCE
)
7921 /* Returns a reference to the scalar evaluated outside the loop
7923 gfc_conv_expr (se
, expr
);
7925 if (expr
->ts
.type
== BT_CHARACTER
7926 && expr
->expr_type
!= EXPR_FUNCTION
)
7927 gfc_conv_string_parameter (se
);
7929 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7934 if (expr
->ts
.type
== BT_CHARACTER
)
7936 gfc_conv_expr (se
, expr
);
7937 gfc_conv_string_parameter (se
);
7941 if (expr
->expr_type
== EXPR_VARIABLE
)
7943 se
->want_pointer
= 1;
7944 gfc_conv_expr (se
, expr
);
7947 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7948 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7949 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7955 if (expr
->expr_type
== EXPR_FUNCTION
7956 && ((expr
->value
.function
.esym
7957 && expr
->value
.function
.esym
->result
->attr
.pointer
7958 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7959 || (!expr
->value
.function
.esym
&& !expr
->ref
7960 && expr
->symtree
->n
.sym
->attr
.pointer
7961 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7963 se
->want_pointer
= 1;
7964 gfc_conv_expr (se
, expr
);
7965 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7966 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7971 gfc_conv_expr (se
, expr
);
7973 /* Create a temporary var to hold the value. */
7974 if (TREE_CONSTANT (se
->expr
))
7976 tree tmp
= se
->expr
;
7977 STRIP_TYPE_NOPS (tmp
);
7978 var
= build_decl (input_location
,
7979 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7980 DECL_INITIAL (var
) = tmp
;
7981 TREE_STATIC (var
) = 1;
7986 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7987 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7989 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7991 /* Take the address of that value. */
7992 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7996 /* Get the _len component for an unlimited polymorphic expression. */
7999 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8002 gfc_ref
*ref
= expr
->ref
;
8004 gfc_init_se (&se
, NULL
);
8005 while (ref
&& ref
->next
)
8007 gfc_add_len_component (expr
);
8008 gfc_conv_expr (&se
, expr
);
8009 gfc_add_block_to_block (block
, &se
.pre
);
8010 gcc_assert (se
.post
.head
== NULL_TREE
);
8013 gfc_free_ref_list (ref
->next
);
8018 gfc_free_ref_list (expr
->ref
);
8025 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8026 statement-list outside of the scalarizer-loop. When code is generated, that
8027 depends on the scalarized expression, it is added to RSE.PRE.
8028 Returns le's _vptr tree and when set the len expressions in to_lenp and
8029 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8033 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8034 gfc_expr
* re
, gfc_se
*rse
,
8035 tree
* to_lenp
, tree
* from_lenp
)
8038 gfc_expr
* vptr_expr
;
8039 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8040 bool set_vptr
= false, temp_rhs
= false;
8041 stmtblock_t
*pre
= block
;
8043 /* Create a temporary for complicated expressions. */
8044 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8045 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8047 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8049 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8054 /* Get the _vptr for the left-hand side expression. */
8055 gfc_init_se (&se
, NULL
);
8056 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8057 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8059 /* Care about _len for unlimited polymorphic entities. */
8060 if (UNLIMITED_POLY (vptr_expr
)
8061 || (vptr_expr
->ts
.type
== BT_DERIVED
8062 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8063 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8064 gfc_add_vptr_component (vptr_expr
);
8068 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8069 se
.want_pointer
= 1;
8070 gfc_conv_expr (&se
, vptr_expr
);
8071 gfc_free_expr (vptr_expr
);
8072 gfc_add_block_to_block (block
, &se
.pre
);
8073 gcc_assert (se
.post
.head
== NULL_TREE
);
8075 STRIP_NOPS (lhs_vptr
);
8077 /* Set the _vptr only when the left-hand side of the assignment is a
8081 /* Get the vptr from the rhs expression only, when it is variable.
8082 Functions are expected to be assigned to a temporary beforehand. */
8083 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8084 ? gfc_find_and_cut_at_last_class_ref (re
)
8086 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8088 if (to_len
!= NULL_TREE
)
8090 /* Get the _len information from the rhs. */
8091 if (UNLIMITED_POLY (vptr_expr
)
8092 || (vptr_expr
->ts
.type
== BT_DERIVED
8093 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8094 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8096 gfc_add_vptr_component (vptr_expr
);
8100 if (re
->expr_type
== EXPR_VARIABLE
8101 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8102 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8103 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8104 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8105 re
->symtree
->n
.sym
->backend_decl
))))
8108 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8109 re
->symtree
->n
.sym
->backend_decl
));
8111 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8112 re
->symtree
->n
.sym
->backend_decl
));
8114 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8117 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8119 else if (re
->expr_type
!= EXPR_NULL
)
8120 /* Only when rhs is non-NULL use its declared type for vptr
8122 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8124 /* When the rhs is NULL use the vtab of lhs' declared type. */
8125 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8130 gfc_init_se (&se
, NULL
);
8131 se
.want_pointer
= 1;
8132 gfc_conv_expr (&se
, vptr_expr
);
8133 gfc_free_expr (vptr_expr
);
8134 gfc_add_block_to_block (block
, &se
.pre
);
8135 gcc_assert (se
.post
.head
== NULL_TREE
);
8137 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8140 if (to_len
!= NULL_TREE
)
8142 /* The _len component needs to be set. Figure how to get the
8143 value of the right-hand side. */
8144 if (from_len
== NULL_TREE
)
8146 if (rse
->string_length
!= NULL_TREE
)
8147 from_len
= rse
->string_length
;
8148 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8150 from_len
= gfc_get_expr_charlen (re
);
8151 gfc_init_se (&se
, NULL
);
8152 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8153 gfc_add_block_to_block (block
, &se
.pre
);
8154 gcc_assert (se
.post
.head
== NULL_TREE
);
8155 from_len
= gfc_evaluate_now (se
.expr
, block
);
8158 from_len
= integer_zero_node
;
8160 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8165 /* Return the _len trees only, when requested. */
8169 *from_lenp
= from_len
;
8174 /* Assign tokens for pointer components. */
8177 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8180 symbol_attribute lhs_attr
, rhs_attr
;
8181 tree tmp
, lhs_tok
, rhs_tok
;
8182 /* Flag to indicated component refs on the rhs. */
8185 lhs_attr
= gfc_caf_attr (expr1
);
8186 if (expr2
->expr_type
!= EXPR_NULL
)
8188 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8189 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8191 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8192 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8195 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8199 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8200 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8203 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8205 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8206 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8209 else if (lhs_attr
.codimension
)
8211 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8212 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8213 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8214 lhs_tok
, null_pointer_node
);
8215 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8219 /* Indentify class valued proc_pointer assignments. */
8222 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8227 while (ref
&& ref
->next
)
8230 return ref
&& ref
->type
== REF_COMPONENT
8231 && ref
->u
.c
.component
->attr
.proc_pointer
8232 && expr2
->expr_type
== EXPR_VARIABLE
8233 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8237 /* Do everything that is needed for a CLASS function expr2. */
8240 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8241 gfc_expr
*expr1
, gfc_expr
*expr2
)
8243 tree expr1_vptr
= NULL_TREE
;
8246 gfc_conv_function_expr (rse
, expr2
);
8247 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8249 if (expr1
->ts
.type
!= BT_CLASS
)
8250 rse
->expr
= gfc_class_data_get (rse
->expr
);
8253 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8256 gfc_add_block_to_block (block
, &rse
->pre
);
8257 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8258 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8260 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8261 fold_convert (TREE_TYPE (expr1_vptr
),
8262 gfc_class_vptr_get (tmp
)));
8263 rse
->expr
= gfc_class_data_get (tmp
);
8271 gfc_trans_pointer_assign (gfc_code
* code
)
8273 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8277 /* Generate code for a pointer assignment. */
8280 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8287 tree expr1_vptr
= NULL_TREE
;
8288 bool scalar
, non_proc_pointer_assign
;
8291 gfc_start_block (&block
);
8293 gfc_init_se (&lse
, NULL
);
8295 /* Usually testing whether this is not a proc pointer assignment. */
8296 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8298 /* Check whether the expression is a scalar or not; we cannot use
8299 expr1->rank as it can be nonzero for proc pointers. */
8300 ss
= gfc_walk_expr (expr1
);
8301 scalar
= ss
== gfc_ss_terminator
;
8303 gfc_free_ss_chain (ss
);
8305 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8306 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8308 gfc_add_data_component (expr2
);
8309 /* The following is required as gfc_add_data_component doesn't
8310 update ts.type if there is a tailing REF_ARRAY. */
8311 expr2
->ts
.type
= BT_DERIVED
;
8316 /* Scalar pointers. */
8317 lse
.want_pointer
= 1;
8318 gfc_conv_expr (&lse
, expr1
);
8319 gfc_init_se (&rse
, NULL
);
8320 rse
.want_pointer
= 1;
8321 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8322 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8324 gfc_conv_expr (&rse
, expr2
);
8326 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8328 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8330 lse
.expr
= gfc_class_data_get (lse
.expr
);
8333 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8334 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8335 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8338 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8339 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8340 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8343 gfc_add_block_to_block (&block
, &lse
.pre
);
8344 gfc_add_block_to_block (&block
, &rse
.pre
);
8346 /* Check character lengths if character expression. The test is only
8347 really added if -fbounds-check is enabled. Exclude deferred
8348 character length lefthand sides. */
8349 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8350 && !expr1
->ts
.deferred
8351 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8352 && !gfc_is_proc_ptr_comp (expr1
))
8354 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8355 gcc_assert (lse
.string_length
&& rse
.string_length
);
8356 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8357 lse
.string_length
, rse
.string_length
,
8361 /* The assignment to an deferred character length sets the string
8362 length to that of the rhs. */
8363 if (expr1
->ts
.deferred
)
8365 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8366 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
8367 else if (lse
.string_length
!= NULL
)
8368 gfc_add_modify (&block
, lse
.string_length
,
8369 build_int_cst (gfc_charlen_type_node
, 0));
8372 gfc_add_modify (&block
, lse
.expr
,
8373 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8375 /* Also set the tokens for pointer components in derived typed
8377 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8378 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8380 gfc_add_block_to_block (&block
, &rse
.post
);
8381 gfc_add_block_to_block (&block
, &lse
.post
);
8388 tree strlen_rhs
= NULL_TREE
;
8390 /* Array pointer. Find the last reference on the LHS and if it is an
8391 array section ref, we're dealing with bounds remapping. In this case,
8392 set it to AR_FULL so that gfc_conv_expr_descriptor does
8393 not see it and process the bounds remapping afterwards explicitly. */
8394 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8395 if (!remap
->next
&& remap
->type
== REF_ARRAY
8396 && remap
->u
.ar
.type
== AR_SECTION
)
8398 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8400 gfc_init_se (&lse
, NULL
);
8402 lse
.descriptor_only
= 1;
8403 gfc_conv_expr_descriptor (&lse
, expr1
);
8404 strlen_lhs
= lse
.string_length
;
8407 if (expr2
->expr_type
== EXPR_NULL
)
8409 /* Just set the data pointer to null. */
8410 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8412 else if (rank_remap
)
8414 /* If we are rank-remapping, just get the RHS's descriptor and
8415 process this later on. */
8416 gfc_init_se (&rse
, NULL
);
8417 rse
.direct_byref
= 1;
8418 rse
.byref_noassign
= 1;
8420 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8421 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8423 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8425 tree bound
[GFC_MAX_DIMENSIONS
];
8428 for (i
= 0; i
< expr2
->rank
; i
++)
8429 bound
[i
] = NULL_TREE
;
8430 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8431 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8433 GFC_ARRAY_POINTER_CONT
, false);
8434 tmp
= gfc_create_var (tmp
, "ptrtemp");
8435 rse
.descriptor_only
= 0;
8437 rse
.direct_byref
= 1;
8438 gfc_conv_expr_descriptor (&rse
, expr2
);
8439 strlen_rhs
= rse
.string_length
;
8444 gfc_conv_expr_descriptor (&rse
, expr2
);
8445 strlen_rhs
= rse
.string_length
;
8446 if (expr1
->ts
.type
== BT_CLASS
)
8447 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8452 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8454 /* Assign directly to the LHS's descriptor. */
8455 lse
.descriptor_only
= 0;
8456 lse
.direct_byref
= 1;
8457 gfc_conv_expr_descriptor (&lse
, expr2
);
8458 strlen_rhs
= lse
.string_length
;
8460 if (expr1
->ts
.type
== BT_CLASS
)
8462 rse
.expr
= NULL_TREE
;
8463 rse
.string_length
= NULL_TREE
;
8464 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8470 /* If the target is not a whole array, use the target array
8471 reference for remap. */
8472 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8473 if (remap
->type
== REF_ARRAY
8474 && remap
->u
.ar
.type
== AR_FULL
8479 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8481 gfc_init_se (&rse
, NULL
);
8482 rse
.want_pointer
= 1;
8483 gfc_conv_function_expr (&rse
, expr2
);
8484 if (expr1
->ts
.type
!= BT_CLASS
)
8486 rse
.expr
= gfc_class_data_get (rse
.expr
);
8487 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8488 /* Set the lhs span. */
8489 tmp
= TREE_TYPE (rse
.expr
);
8490 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8491 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8492 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8496 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8499 gfc_add_block_to_block (&block
, &rse
.pre
);
8500 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8501 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8503 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8504 fold_convert (TREE_TYPE (expr1_vptr
),
8505 gfc_class_vptr_get (tmp
)));
8506 rse
.expr
= gfc_class_data_get (tmp
);
8507 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8512 /* Assign to a temporary descriptor and then copy that
8513 temporary to the pointer. */
8514 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8515 lse
.descriptor_only
= 0;
8517 lse
.direct_byref
= 1;
8518 gfc_conv_expr_descriptor (&lse
, expr2
);
8519 strlen_rhs
= lse
.string_length
;
8520 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8523 gfc_add_block_to_block (&block
, &lse
.pre
);
8525 gfc_add_block_to_block (&block
, &rse
.pre
);
8527 /* If we do bounds remapping, update LHS descriptor accordingly. */
8531 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8535 /* Do rank remapping. We already have the RHS's descriptor
8536 converted in rse and now have to build the correct LHS
8537 descriptor for it. */
8539 tree dtype
, data
, span
;
8541 tree lbound
, ubound
;
8544 dtype
= gfc_conv_descriptor_dtype (desc
);
8545 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8546 gfc_add_modify (&block
, dtype
, tmp
);
8548 /* Copy data pointer. */
8549 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8550 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8552 /* Copy the span. */
8553 if (TREE_CODE (rse
.expr
) == VAR_DECL
8554 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8555 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8558 tmp
= TREE_TYPE (rse
.expr
);
8559 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8560 span
= fold_convert (gfc_array_index_type
, tmp
);
8562 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8564 /* Copy offset but adjust it such that it would correspond
8565 to a lbound of zero. */
8566 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8567 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8569 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8571 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8573 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8574 gfc_array_index_type
, stride
, lbound
);
8575 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8576 gfc_array_index_type
, offs
, tmp
);
8578 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8580 /* Set the bounds as declared for the LHS and calculate strides as
8581 well as another offset update accordingly. */
8582 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8584 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8589 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8591 /* Convert declared bounds. */
8592 gfc_init_se (&lower_se
, NULL
);
8593 gfc_init_se (&upper_se
, NULL
);
8594 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8595 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8597 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8598 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8600 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8601 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8603 lbound
= gfc_evaluate_now (lbound
, &block
);
8604 ubound
= gfc_evaluate_now (ubound
, &block
);
8606 gfc_add_block_to_block (&block
, &lower_se
.post
);
8607 gfc_add_block_to_block (&block
, &upper_se
.post
);
8609 /* Set bounds in descriptor. */
8610 gfc_conv_descriptor_lbound_set (&block
, desc
,
8611 gfc_rank_cst
[dim
], lbound
);
8612 gfc_conv_descriptor_ubound_set (&block
, desc
,
8613 gfc_rank_cst
[dim
], ubound
);
8616 stride
= gfc_evaluate_now (stride
, &block
);
8617 gfc_conv_descriptor_stride_set (&block
, desc
,
8618 gfc_rank_cst
[dim
], stride
);
8620 /* Update offset. */
8621 offs
= gfc_conv_descriptor_offset_get (desc
);
8622 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8623 gfc_array_index_type
, lbound
, stride
);
8624 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8625 gfc_array_index_type
, offs
, tmp
);
8626 offs
= gfc_evaluate_now (offs
, &block
);
8627 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8629 /* Update stride. */
8630 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8631 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8632 gfc_array_index_type
, stride
, tmp
);
8637 /* Bounds remapping. Just shift the lower bounds. */
8639 gcc_assert (expr1
->rank
== expr2
->rank
);
8641 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8645 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8646 gfc_init_se (&lbound_se
, NULL
);
8647 if (remap
->u
.ar
.start
[dim
])
8649 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8650 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8653 /* This remap arises from a target that is not a whole
8654 array. The start expressions will be NULL but we need
8655 the lbounds to be one. */
8656 lbound_se
.expr
= gfc_index_one_node
;
8657 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8658 dim
, lbound_se
.expr
);
8659 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8664 /* Check string lengths if applicable. The check is only really added
8665 to the output code if -fbounds-check is enabled. */
8666 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8668 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8669 gcc_assert (strlen_lhs
&& strlen_rhs
);
8670 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8671 strlen_lhs
, strlen_rhs
, &block
);
8674 /* If rank remapping was done, check with -fcheck=bounds that
8675 the target is at least as large as the pointer. */
8676 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8682 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8683 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8685 lsize
= gfc_evaluate_now (lsize
, &block
);
8686 rsize
= gfc_evaluate_now (rsize
, &block
);
8687 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
8690 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8691 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8695 gfc_add_block_to_block (&block
, &lse
.post
);
8697 gfc_add_block_to_block (&block
, &rse
.post
);
8700 return gfc_finish_block (&block
);
8704 /* Makes sure se is suitable for passing as a function string parameter. */
8705 /* TODO: Need to check all callers of this function. It may be abused. */
8708 gfc_conv_string_parameter (gfc_se
* se
)
8712 if (TREE_CODE (se
->expr
) == STRING_CST
)
8714 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8715 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8719 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8721 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8723 type
= TREE_TYPE (se
->expr
);
8724 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8728 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8730 type
= build_pointer_type (type
);
8731 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8735 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8739 /* Generate code for assignment of scalar variables. Includes character
8740 strings and derived types with allocatable components.
8741 If you know that the LHS has no allocations, set dealloc to false.
8743 DEEP_COPY has no effect if the typespec TS is not a derived type with
8744 allocatable components. Otherwise, if it is set, an explicit copy of each
8745 allocatable component is made. This is necessary as a simple copy of the
8746 whole object would copy array descriptors as is, so that the lhs's
8747 allocatable components would point to the rhs's after the assignment.
8748 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8749 necessary if the rhs is a non-pointer function, as the allocatable components
8750 are not accessible by other means than the function's result after the
8751 function has returned. It is even more subtle when temporaries are involved,
8752 as the two following examples show:
8753 1. When we evaluate an array constructor, a temporary is created. Thus
8754 there is theoretically no alias possible. However, no deep copy is
8755 made for this temporary, so that if the constructor is made of one or
8756 more variable with allocatable components, those components still point
8757 to the variable's: DEEP_COPY should be set for the assignment from the
8758 temporary to the lhs in that case.
8759 2. When assigning a scalar to an array, we evaluate the scalar value out
8760 of the loop, store it into a temporary variable, and assign from that.
8761 In that case, deep copying when assigning to the temporary would be a
8762 waste of resources; however deep copies should happen when assigning from
8763 the temporary to each array element: again DEEP_COPY should be set for
8764 the assignment from the temporary to the lhs. */
8767 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8768 bool deep_copy
, bool dealloc
, bool in_coarray
)
8774 gfc_init_block (&block
);
8776 if (ts
.type
== BT_CHARACTER
)
8781 if (lse
->string_length
!= NULL_TREE
)
8783 gfc_conv_string_parameter (lse
);
8784 gfc_add_block_to_block (&block
, &lse
->pre
);
8785 llen
= lse
->string_length
;
8788 if (rse
->string_length
!= NULL_TREE
)
8790 gfc_conv_string_parameter (rse
);
8791 gfc_add_block_to_block (&block
, &rse
->pre
);
8792 rlen
= rse
->string_length
;
8795 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8796 rse
->expr
, ts
.kind
);
8798 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8800 tree tmp_var
= NULL_TREE
;
8803 /* Are the rhs and the lhs the same? */
8806 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8807 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8808 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8809 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8812 /* Deallocate the lhs allocated components as long as it is not
8813 the same as the rhs. This must be done following the assignment
8814 to prevent deallocating data that could be used in the rhs
8818 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8819 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8821 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8823 gfc_add_expr_to_block (&lse
->post
, tmp
);
8826 gfc_add_block_to_block (&block
, &rse
->pre
);
8827 gfc_add_block_to_block (&block
, &lse
->pre
);
8829 gfc_add_modify (&block
, lse
->expr
,
8830 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8832 /* Restore pointer address of coarray components. */
8833 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8835 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8836 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8838 gfc_add_expr_to_block (&block
, tmp
);
8841 /* Do a deep copy if the rhs is a variable, if it is not the
8845 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8846 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
8847 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
8849 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8851 gfc_add_expr_to_block (&block
, tmp
);
8854 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8856 gfc_add_block_to_block (&block
, &lse
->pre
);
8857 gfc_add_block_to_block (&block
, &rse
->pre
);
8858 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8859 TREE_TYPE (lse
->expr
), rse
->expr
);
8860 gfc_add_modify (&block
, lse
->expr
, tmp
);
8864 gfc_add_block_to_block (&block
, &lse
->pre
);
8865 gfc_add_block_to_block (&block
, &rse
->pre
);
8867 gfc_add_modify (&block
, lse
->expr
,
8868 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8871 gfc_add_block_to_block (&block
, &lse
->post
);
8872 gfc_add_block_to_block (&block
, &rse
->post
);
8874 return gfc_finish_block (&block
);
8878 /* There are quite a lot of restrictions on the optimisation in using an
8879 array function assign without a temporary. */
8882 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8885 bool seen_array_ref
;
8887 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8889 /* Play it safe with class functions assigned to a derived type. */
8890 if (gfc_is_alloc_class_array_function (expr2
)
8891 && expr1
->ts
.type
== BT_DERIVED
)
8894 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8895 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8898 /* Elemental functions are scalarized so that they don't need a
8899 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8900 they would need special treatment in gfc_trans_arrayfunc_assign. */
8901 if (expr2
->value
.function
.esym
!= NULL
8902 && expr2
->value
.function
.esym
->attr
.elemental
)
8905 /* Need a temporary if rhs is not FULL or a contiguous section. */
8906 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8909 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8910 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8913 /* Functions returning pointers or allocatables need temporaries. */
8914 c
= expr2
->value
.function
.esym
8915 ? (expr2
->value
.function
.esym
->attr
.pointer
8916 || expr2
->value
.function
.esym
->attr
.allocatable
)
8917 : (expr2
->symtree
->n
.sym
->attr
.pointer
8918 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8922 /* Character array functions need temporaries unless the
8923 character lengths are the same. */
8924 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8926 if (expr1
->ts
.u
.cl
->length
== NULL
8927 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8930 if (expr2
->ts
.u
.cl
->length
== NULL
8931 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8934 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8935 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8939 /* Check that no LHS component references appear during an array
8940 reference. This is needed because we do not have the means to
8941 span any arbitrary stride with an array descriptor. This check
8942 is not needed for the rhs because the function result has to be
8944 seen_array_ref
= false;
8945 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8947 if (ref
->type
== REF_ARRAY
)
8948 seen_array_ref
= true;
8949 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8953 /* Check for a dependency. */
8954 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8955 expr2
->value
.function
.esym
,
8956 expr2
->value
.function
.actual
,
8960 /* If we have reached here with an intrinsic function, we do not
8961 need a temporary except in the particular case that reallocation
8962 on assignment is active and the lhs is allocatable and a target. */
8963 if (expr2
->value
.function
.isym
)
8964 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8966 /* If the LHS is a dummy, we need a temporary if it is not
8968 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8971 /* If the lhs has been host_associated, is in common, a pointer or is
8972 a target and the function is not using a RESULT variable, aliasing
8973 can occur and a temporary is needed. */
8974 if ((sym
->attr
.host_assoc
8975 || sym
->attr
.in_common
8976 || sym
->attr
.pointer
8977 || sym
->attr
.cray_pointee
8978 || sym
->attr
.target
)
8979 && expr2
->symtree
!= NULL
8980 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8983 /* A PURE function can unconditionally be called without a temporary. */
8984 if (expr2
->value
.function
.esym
!= NULL
8985 && expr2
->value
.function
.esym
->attr
.pure
)
8988 /* Implicit_pure functions are those which could legally be declared
8990 if (expr2
->value
.function
.esym
!= NULL
8991 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8994 if (!sym
->attr
.use_assoc
8995 && !sym
->attr
.in_common
8996 && !sym
->attr
.pointer
8997 && !sym
->attr
.target
8998 && !sym
->attr
.cray_pointee
8999 && expr2
->value
.function
.esym
)
9001 /* A temporary is not needed if the function is not contained and
9002 the variable is local or host associated and not a pointer or
9004 if (!expr2
->value
.function
.esym
->attr
.contained
)
9007 /* A temporary is not needed if the lhs has never been host
9008 associated and the procedure is contained. */
9009 else if (!sym
->attr
.host_assoc
)
9012 /* A temporary is not needed if the variable is local and not
9013 a pointer, a target or a result. */
9015 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9019 /* Default to temporary use. */
9024 /* Provide the loop info so that the lhs descriptor can be built for
9025 reallocatable assignments from extrinsic function calls. */
9028 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9031 /* Signal that the function call should not be made by
9032 gfc_conv_loop_setup. */
9033 se
->ss
->is_alloc_lhs
= 1;
9034 gfc_init_loopinfo (loop
);
9035 gfc_add_ss_to_loop (loop
, *ss
);
9036 gfc_add_ss_to_loop (loop
, se
->ss
);
9037 gfc_conv_ss_startstride (loop
);
9038 gfc_conv_loop_setup (loop
, where
);
9039 gfc_copy_loopinfo_to_se (se
, loop
);
9040 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9041 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9042 se
->ss
->is_alloc_lhs
= 0;
9046 /* For assignment to a reallocatable lhs from intrinsic functions,
9047 replace the se.expr (ie. the result) with a temporary descriptor.
9048 Null the data field so that the library allocates space for the
9049 result. Free the data of the original descriptor after the function,
9050 in case it appears in an argument expression and transfer the
9051 result to the original descriptor. */
9054 fcncall_realloc_result (gfc_se
*se
, int rank
)
9063 /* Use the allocation done by the library. Substitute the lhs
9064 descriptor with a copy, whose data field is nulled.*/
9065 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9066 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9067 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9069 /* Unallocated, the descriptor does not have a dtype. */
9070 tmp
= gfc_conv_descriptor_dtype (desc
);
9071 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9073 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9074 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9075 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9077 /* Free the lhs after the function call and copy the result data to
9078 the lhs descriptor. */
9079 tmp
= gfc_conv_descriptor_data_get (desc
);
9080 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9081 logical_type_node
, tmp
,
9082 build_int_cst (TREE_TYPE (tmp
), 0));
9083 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9084 tmp
= gfc_call_free (tmp
);
9085 gfc_add_expr_to_block (&se
->post
, tmp
);
9087 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9088 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9090 /* Check that the shapes are the same between lhs and expression. */
9091 for (n
= 0 ; n
< rank
; n
++)
9094 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9095 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9096 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9097 gfc_array_index_type
, tmp
, tmp1
);
9098 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9099 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9100 gfc_array_index_type
, tmp
, tmp1
);
9101 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9102 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9103 gfc_array_index_type
, tmp
, tmp1
);
9104 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9105 logical_type_node
, tmp
,
9106 gfc_index_zero_node
);
9107 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9108 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9109 logical_type_node
, tmp
,
9113 /* 'zero_cond' being true is equal to lhs not being allocated or the
9114 shapes being different. */
9115 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9117 /* Now reset the bounds returned from the function call to bounds based
9118 on the lhs lbounds, except where the lhs is not allocated or the shapes
9119 of 'variable and 'expr' are different. Set the offset accordingly. */
9120 offset
= gfc_index_zero_node
;
9121 for (n
= 0 ; n
< rank
; n
++)
9125 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9126 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9127 gfc_array_index_type
, zero_cond
,
9128 gfc_index_one_node
, lbound
);
9129 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9131 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9132 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9133 gfc_array_index_type
, tmp
, lbound
);
9134 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9135 gfc_rank_cst
[n
], lbound
);
9136 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9137 gfc_rank_cst
[n
], tmp
);
9139 /* Set stride and accumulate the offset. */
9140 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9141 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9142 gfc_rank_cst
[n
], tmp
);
9143 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9144 gfc_array_index_type
, lbound
, tmp
);
9145 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9146 gfc_array_index_type
, offset
, tmp
);
9147 offset
= gfc_evaluate_now (offset
, &se
->post
);
9150 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9155 /* Try to translate array(:) = func (...), where func is a transformational
9156 array function, without using a temporary. Returns NULL if this isn't the
9160 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9164 gfc_component
*comp
= NULL
;
9167 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9170 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9172 comp
= gfc_get_proc_ptr_comp (expr2
);
9173 gcc_assert (expr2
->value
.function
.isym
9174 || (comp
&& comp
->attr
.dimension
)
9175 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9176 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
9178 gfc_init_se (&se
, NULL
);
9179 gfc_start_block (&se
.pre
);
9180 se
.want_pointer
= 1;
9182 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9184 if (expr1
->ts
.type
== BT_DERIVED
9185 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9188 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9190 gfc_add_expr_to_block (&se
.pre
, tmp
);
9193 se
.direct_byref
= 1;
9194 se
.ss
= gfc_walk_expr (expr2
);
9195 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9197 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9198 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9199 Clearly, this cannot be done for an allocatable function result, since
9200 the shape of the result is unknown and, in any case, the function must
9201 correctly take care of the reallocation internally. For intrinsic
9202 calls, the array data is freed and the library takes care of allocation.
9203 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9205 if (flag_realloc_lhs
9206 && gfc_is_reallocatable_lhs (expr1
)
9207 && !gfc_expr_attr (expr1
).codimension
9208 && !gfc_is_coindexed (expr1
)
9209 && !(expr2
->value
.function
.esym
9210 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9212 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9214 if (!expr2
->value
.function
.isym
)
9216 ss
= gfc_walk_expr (expr1
);
9217 gcc_assert (ss
!= gfc_ss_terminator
);
9219 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9220 ss
->is_alloc_lhs
= 1;
9223 fcncall_realloc_result (&se
, expr1
->rank
);
9226 gfc_conv_function_expr (&se
, expr2
);
9227 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9230 gfc_cleanup_loop (&loop
);
9232 gfc_free_ss_chain (se
.ss
);
9234 return gfc_finish_block (&se
.pre
);
9238 /* Try to efficiently translate array(:) = 0. Return NULL if this
9242 gfc_trans_zero_assign (gfc_expr
* expr
)
9244 tree dest
, len
, type
;
9248 sym
= expr
->symtree
->n
.sym
;
9249 dest
= gfc_get_symbol_decl (sym
);
9251 type
= TREE_TYPE (dest
);
9252 if (POINTER_TYPE_P (type
))
9253 type
= TREE_TYPE (type
);
9254 if (!GFC_ARRAY_TYPE_P (type
))
9257 /* Determine the length of the array. */
9258 len
= GFC_TYPE_ARRAY_SIZE (type
);
9259 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9262 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9263 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9264 fold_convert (gfc_array_index_type
, tmp
));
9266 /* If we are zeroing a local array avoid taking its address by emitting
9268 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9269 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9270 dest
, build_constructor (TREE_TYPE (dest
),
9273 /* Convert arguments to the correct types. */
9274 dest
= fold_convert (pvoid_type_node
, dest
);
9275 len
= fold_convert (size_type_node
, len
);
9277 /* Construct call to __builtin_memset. */
9278 tmp
= build_call_expr_loc (input_location
,
9279 builtin_decl_explicit (BUILT_IN_MEMSET
),
9280 3, dest
, integer_zero_node
, len
);
9281 return fold_convert (void_type_node
, tmp
);
9285 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9286 that constructs the call to __builtin_memcpy. */
9289 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9293 /* Convert arguments to the correct types. */
9294 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9295 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9297 dst
= fold_convert (pvoid_type_node
, dst
);
9299 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9300 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9302 src
= fold_convert (pvoid_type_node
, src
);
9304 len
= fold_convert (size_type_node
, len
);
9306 /* Construct call to __builtin_memcpy. */
9307 tmp
= build_call_expr_loc (input_location
,
9308 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9310 return fold_convert (void_type_node
, tmp
);
9314 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9315 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9316 source/rhs, both are gfc_full_array_ref_p which have been checked for
9320 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9322 tree dst
, dlen
, dtype
;
9323 tree src
, slen
, stype
;
9326 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9327 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9329 dtype
= TREE_TYPE (dst
);
9330 if (POINTER_TYPE_P (dtype
))
9331 dtype
= TREE_TYPE (dtype
);
9332 stype
= TREE_TYPE (src
);
9333 if (POINTER_TYPE_P (stype
))
9334 stype
= TREE_TYPE (stype
);
9336 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9339 /* Determine the lengths of the arrays. */
9340 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9341 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9343 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9344 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9345 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9347 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9348 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9350 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9351 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9352 slen
, fold_convert (gfc_array_index_type
, tmp
));
9354 /* Sanity check that they are the same. This should always be
9355 the case, as we should already have checked for conformance. */
9356 if (!tree_int_cst_equal (slen
, dlen
))
9359 return gfc_build_memcpy_call (dst
, src
, dlen
);
9363 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9364 this can't be done. EXPR1 is the destination/lhs for which
9365 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9368 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9370 unsigned HOST_WIDE_INT nelem
;
9376 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9380 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9381 dtype
= TREE_TYPE (dst
);
9382 if (POINTER_TYPE_P (dtype
))
9383 dtype
= TREE_TYPE (dtype
);
9384 if (!GFC_ARRAY_TYPE_P (dtype
))
9387 /* Determine the lengths of the array. */
9388 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9389 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9392 /* Confirm that the constructor is the same size. */
9393 if (compare_tree_int (len
, nelem
) != 0)
9396 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9397 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9398 fold_convert (gfc_array_index_type
, tmp
));
9400 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9401 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9403 stype
= TREE_TYPE (src
);
9404 if (POINTER_TYPE_P (stype
))
9405 stype
= TREE_TYPE (stype
);
9407 return gfc_build_memcpy_call (dst
, src
, len
);
9411 /* Tells whether the expression is to be treated as a variable reference. */
9414 gfc_expr_is_variable (gfc_expr
*expr
)
9417 gfc_component
*comp
;
9418 gfc_symbol
*func_ifc
;
9420 if (expr
->expr_type
== EXPR_VARIABLE
)
9423 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9426 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9427 return gfc_expr_is_variable (arg
);
9430 /* A data-pointer-returning function should be considered as a variable
9432 if (expr
->expr_type
== EXPR_FUNCTION
9433 && expr
->ref
== NULL
)
9435 if (expr
->value
.function
.isym
!= NULL
)
9438 if (expr
->value
.function
.esym
!= NULL
)
9440 func_ifc
= expr
->value
.function
.esym
;
9445 gcc_assert (expr
->symtree
);
9446 func_ifc
= expr
->symtree
->n
.sym
;
9453 comp
= gfc_get_proc_ptr_comp (expr
);
9454 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9457 func_ifc
= comp
->ts
.interface
;
9461 if (expr
->expr_type
== EXPR_COMPCALL
)
9463 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9464 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9471 gcc_assert (func_ifc
->attr
.function
9472 && func_ifc
->result
!= NULL
);
9473 return func_ifc
->result
->attr
.pointer
;
9477 /* Is the lhs OK for automatic reallocation? */
9480 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9484 /* An allocatable variable with no reference. */
9485 if (expr
->symtree
->n
.sym
->attr
.allocatable
9489 /* All that can be left are allocatable components. However, we do
9490 not check for allocatable components here because the expression
9491 could be an allocatable component of a pointer component. */
9492 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9493 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9496 /* Find an allocatable component ref last. */
9497 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9498 if (ref
->type
== REF_COMPONENT
9500 && ref
->u
.c
.component
->attr
.allocatable
)
9507 /* Allocate or reallocate scalar lhs, as necessary. */
9510 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9525 if (!expr1
|| expr1
->rank
)
9528 if (!expr2
|| expr2
->rank
)
9531 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9532 if (ref
->type
== REF_SUBSTRING
)
9535 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9537 /* Since this is a scalar lhs, we can afford to do this. That is,
9538 there is no risk of side effects being repeated. */
9539 gfc_init_se (&lse
, NULL
);
9540 lse
.want_pointer
= 1;
9541 gfc_conv_expr (&lse
, expr1
);
9543 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9544 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9546 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9547 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9548 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9550 tmp
= build3_v (COND_EXPR
, cond
,
9551 build1_v (GOTO_EXPR
, jump_label1
),
9552 build_empty_stmt (input_location
));
9553 gfc_add_expr_to_block (block
, tmp
);
9555 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9557 /* Use the rhs string length and the lhs element size. */
9558 size
= string_length
;
9559 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9560 tmp
= TYPE_SIZE_UNIT (tmp
);
9561 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9562 TREE_TYPE (tmp
), tmp
,
9563 fold_convert (TREE_TYPE (tmp
), size
));
9567 /* Otherwise use the length in bytes of the rhs. */
9568 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9569 size_in_bytes
= size
;
9572 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9573 size_in_bytes
, size_one_node
);
9575 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9577 tree caf_decl
, token
;
9579 symbol_attribute attr
;
9581 gfc_clear_attr (&attr
);
9582 gfc_init_se (&caf_se
, NULL
);
9584 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9585 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9587 gfc_add_block_to_block (block
, &caf_se
.pre
);
9588 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9589 gfc_build_addr_expr (NULL_TREE
, token
),
9590 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9593 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9595 tmp
= build_call_expr_loc (input_location
,
9596 builtin_decl_explicit (BUILT_IN_CALLOC
),
9597 2, build_one_cst (size_type_node
),
9599 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9600 gfc_add_modify (block
, lse
.expr
, tmp
);
9604 tmp
= build_call_expr_loc (input_location
,
9605 builtin_decl_explicit (BUILT_IN_MALLOC
),
9607 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9608 gfc_add_modify (block
, lse
.expr
, tmp
);
9611 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9613 /* Deferred characters need checking for lhs and rhs string
9614 length. Other deferred parameter variables will have to
9616 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9617 gfc_add_expr_to_block (block
, tmp
);
9619 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9620 gfc_add_expr_to_block (block
, tmp
);
9622 /* For a deferred length character, reallocate if lengths of lhs and
9623 rhs are different. */
9624 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9626 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9627 lse
.string_length
, size
);
9628 /* Jump past the realloc if the lengths are the same. */
9629 tmp
= build3_v (COND_EXPR
, cond
,
9630 build1_v (GOTO_EXPR
, jump_label2
),
9631 build_empty_stmt (input_location
));
9632 gfc_add_expr_to_block (block
, tmp
);
9633 tmp
= build_call_expr_loc (input_location
,
9634 builtin_decl_explicit (BUILT_IN_REALLOC
),
9635 2, fold_convert (pvoid_type_node
, lse
.expr
),
9637 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9638 gfc_add_modify (block
, lse
.expr
, tmp
);
9639 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9640 gfc_add_expr_to_block (block
, tmp
);
9642 /* Update the lhs character length. */
9643 size
= string_length
;
9644 gfc_add_modify (block
, lse
.string_length
, size
);
9648 /* Check for assignments of the type
9652 to make sure we do not check for reallocation unneccessarily. */
9656 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9658 gfc_actual_arglist
*a
;
9661 switch (expr2
->expr_type
)
9664 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9667 if (expr2
->value
.function
.esym
9668 && expr2
->value
.function
.esym
->attr
.elemental
)
9670 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9673 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9678 else if (expr2
->value
.function
.isym
9679 && expr2
->value
.function
.isym
->elemental
)
9681 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9684 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9693 switch (expr2
->value
.op
.op
)
9696 case INTRINSIC_UPLUS
:
9697 case INTRINSIC_UMINUS
:
9698 case INTRINSIC_PARENTHESES
:
9699 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9701 case INTRINSIC_PLUS
:
9702 case INTRINSIC_MINUS
:
9703 case INTRINSIC_TIMES
:
9704 case INTRINSIC_DIVIDE
:
9705 case INTRINSIC_POWER
:
9709 case INTRINSIC_NEQV
:
9716 case INTRINSIC_EQ_OS
:
9717 case INTRINSIC_NE_OS
:
9718 case INTRINSIC_GT_OS
:
9719 case INTRINSIC_GE_OS
:
9720 case INTRINSIC_LT_OS
:
9721 case INTRINSIC_LE_OS
:
9723 e1
= expr2
->value
.op
.op1
;
9724 e2
= expr2
->value
.op
.op2
;
9726 if (e1
->rank
== 0 && e2
->rank
> 0)
9727 return is_runtime_conformable (expr1
, e2
);
9728 else if (e1
->rank
> 0 && e2
->rank
== 0)
9729 return is_runtime_conformable (expr1
, e1
);
9730 else if (e1
->rank
> 0 && e2
->rank
> 0)
9731 return is_runtime_conformable (expr1
, e1
)
9732 && is_runtime_conformable (expr1
, e2
);
9750 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9751 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
9754 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
9755 vec
<tree
, va_gc
> *args
= NULL
;
9757 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9760 /* Generate allocation of the lhs. */
9766 tmp
= gfc_vptr_size_get (vptr
);
9767 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9768 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9769 gfc_init_block (&alloc
);
9770 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
9771 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9772 logical_type_node
, class_han
,
9773 build_int_cst (prvoid_type_node
, 0));
9774 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
9776 PRED_FORTRAN_FAIL_ALLOC
),
9777 gfc_finish_block (&alloc
),
9778 build_empty_stmt (input_location
));
9779 gfc_add_expr_to_block (&lse
->pre
, tmp
);
9782 fcn
= gfc_vptr_copy_get (vptr
);
9784 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9785 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9788 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9789 || INDIRECT_REF_P (tmp
)
9790 || (rhs
->ts
.type
== BT_DERIVED
9791 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9792 && !rhs
->ts
.u
.derived
->attr
.pointer
9793 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9794 || (UNLIMITED_POLY (rhs
)
9795 && !CLASS_DATA (rhs
)->attr
.pointer
9796 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9797 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9799 vec_safe_push (args
, tmp
);
9800 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9801 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9802 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9803 || INDIRECT_REF_P (tmp
)
9804 || (lhs
->ts
.type
== BT_DERIVED
9805 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9806 && !lhs
->ts
.u
.derived
->attr
.pointer
9807 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9808 || (UNLIMITED_POLY (lhs
)
9809 && !CLASS_DATA (lhs
)->attr
.pointer
9810 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9811 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9813 vec_safe_push (args
, tmp
);
9815 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9817 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9820 vec_safe_push (args
, from_len
);
9821 vec_safe_push (args
, to_len
);
9822 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9824 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9825 logical_type_node
, from_len
,
9827 return fold_build3_loc (input_location
, COND_EXPR
,
9828 void_type_node
, tmp
,
9836 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9837 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9839 gfc_init_block (&tblock
);
9840 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9841 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9842 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9843 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9844 /* When coming from a ptr_copy lhs and rhs are swapped. */
9845 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9846 fold_convert (TREE_TYPE (rhst
), tmp
));
9847 return gfc_finish_block (&tblock
);
9851 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9852 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9853 init_flag indicates initialization expressions and dealloc that no
9854 deallocate prior assignment is needed (if in doubt, set true).
9855 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9856 routine instead of a pointer assignment. Alias resolution is only done,
9857 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9858 where it is known, that newly allocated memory on the lhs can never be
9859 an alias of the rhs. */
9862 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9863 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9868 gfc_ss
*lss_section
;
9875 bool scalar_to_array
;
9878 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
9879 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9880 bool is_poly_assign
;
9882 /* Assignment of the form lhs = rhs. */
9883 gfc_start_block (&block
);
9885 gfc_init_se (&lse
, NULL
);
9886 gfc_init_se (&rse
, NULL
);
9889 lss
= gfc_walk_expr (expr1
);
9890 if (gfc_is_reallocatable_lhs (expr1
)
9891 && !(expr2
->expr_type
== EXPR_FUNCTION
9892 && expr2
->value
.function
.isym
!= NULL
))
9893 lss
->is_alloc_lhs
= 1;
9896 if ((expr1
->ts
.type
== BT_DERIVED
)
9897 && (gfc_is_alloc_class_array_function (expr2
)
9898 || gfc_is_alloc_class_scalar_function (expr2
)))
9899 expr2
->must_finalize
= 1;
9901 /* Checking whether a class assignment is desired is quite complicated and
9902 needed at two locations, so do it once only before the information is
9904 lhs_attr
= gfc_expr_attr (expr1
);
9905 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
9906 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9907 && (expr1
->ts
.type
== BT_CLASS
9908 || gfc_is_class_array_ref (expr1
, NULL
)
9909 || gfc_is_class_scalar_expr (expr1
)
9910 || gfc_is_class_array_ref (expr2
, NULL
)
9911 || gfc_is_class_scalar_expr (expr2
));
9914 /* Only analyze the expressions for coarray properties, when in coarray-lib
9916 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9918 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
9919 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
9922 if (lss
!= gfc_ss_terminator
)
9924 /* The assignment needs scalarization. */
9927 /* Find a non-scalar SS from the lhs. */
9928 while (lss_section
!= gfc_ss_terminator
9929 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9930 lss_section
= lss_section
->next
;
9932 gcc_assert (lss_section
!= gfc_ss_terminator
);
9934 /* Initialize the scalarizer. */
9935 gfc_init_loopinfo (&loop
);
9938 rss
= gfc_walk_expr (expr2
);
9939 if (rss
== gfc_ss_terminator
)
9940 /* The rhs is scalar. Add a ss for the expression. */
9941 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9942 /* When doing a class assign, then the handle to the rhs needs to be a
9943 pointer to allow for polymorphism. */
9944 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
9945 rss
->info
->type
= GFC_SS_REFERENCE
;
9947 /* Associate the SS with the loop. */
9948 gfc_add_ss_to_loop (&loop
, lss
);
9949 gfc_add_ss_to_loop (&loop
, rss
);
9951 /* Calculate the bounds of the scalarization. */
9952 gfc_conv_ss_startstride (&loop
);
9953 /* Enable loop reversal. */
9954 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9955 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9956 /* Resolve any data dependencies in the statement. */
9958 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9959 /* Setup the scalarizing loops. */
9960 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9962 /* Setup the gfc_se structures. */
9963 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9964 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9967 gfc_mark_ss_chain_used (rss
, 1);
9968 if (loop
.temp_ss
== NULL
)
9971 gfc_mark_ss_chain_used (lss
, 1);
9975 lse
.ss
= loop
.temp_ss
;
9976 gfc_mark_ss_chain_used (lss
, 3);
9977 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9980 /* Allow the scalarizer to workshare array assignments. */
9981 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
9982 == OMPWS_WORKSHARE_FLAG
9983 && loop
.temp_ss
== NULL
)
9985 maybe_workshare
= true;
9986 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
9989 /* Start the scalarized loop body. */
9990 gfc_start_scalarized_body (&loop
, &body
);
9993 gfc_init_block (&body
);
9995 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9997 /* Translate the expression. */
9998 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
9999 && lhs_caf_attr
.codimension
;
10000 gfc_conv_expr (&rse
, expr2
);
10002 /* Deal with the case of a scalar class function assigned to a derived type. */
10003 if (gfc_is_alloc_class_scalar_function (expr2
)
10004 && expr1
->ts
.type
== BT_DERIVED
)
10006 rse
.expr
= gfc_class_data_get (rse
.expr
);
10007 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10010 /* Stabilize a string length for temporaries. */
10011 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10012 && !(VAR_P (rse
.string_length
)
10013 || TREE_CODE (rse
.string_length
) == PARM_DECL
10014 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10015 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10016 else if (expr2
->ts
.type
== BT_CHARACTER
)
10017 string_length
= rse
.string_length
;
10019 string_length
= NULL_TREE
;
10023 gfc_conv_tmp_array_ref (&lse
);
10024 if (expr2
->ts
.type
== BT_CHARACTER
)
10025 lse
.string_length
= string_length
;
10029 gfc_conv_expr (&lse
, expr1
);
10030 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10032 && gfc_expr_attr (expr1
).allocatable
10039 tmp
= INDIRECT_REF_P (lse
.expr
)
10040 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10042 /* We should only get array references here. */
10043 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10044 || TREE_CODE (tmp
) == ARRAY_REF
);
10046 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10047 or the array itself(ARRAY_REF). */
10048 tmp
= TREE_OPERAND (tmp
, 0);
10050 /* Provide the address of the array. */
10051 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10052 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10054 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10055 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10056 msg
= _("Assignment of scalar to unallocated array");
10057 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10058 &expr1
->where
, msg
);
10062 /* Assignments of scalar derived types with allocatable components
10063 to arrays must be done with a deep copy and the rhs temporary
10064 must have its components deallocated afterwards. */
10065 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10066 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10067 && !gfc_expr_is_variable (expr2
)
10068 && expr1
->rank
&& !expr2
->rank
);
10069 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10071 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10072 && gfc_is_alloc_class_scalar_function (expr2
));
10073 if (scalar_to_array
&& dealloc
)
10075 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10076 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10079 /* When assigning a character function result to a deferred-length variable,
10080 the function call must happen before the (re)allocation of the lhs -
10081 otherwise the character length of the result is not known.
10082 NOTE: This relies on having the exact dependence of the length type
10083 parameter available to the caller; gfortran saves it in the .mod files.
10084 NOTE ALSO: The concatenation operation generates a temporary pointer,
10085 whose allocation must go to the innermost loop.
10086 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10087 if (flag_realloc_lhs
10088 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10089 && !(lss
!= gfc_ss_terminator
10090 && ((expr2
->expr_type
== EXPR_OP
10091 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10092 || (expr2
->expr_type
== EXPR_FUNCTION
10093 && expr2
->value
.function
.isym
!= NULL
10094 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
))))
10095 gfc_add_block_to_block (&block
, &rse
.pre
);
10097 /* Nullify the allocatable components corresponding to those of the lhs
10098 derived type, so that the finalization of the function result does not
10099 affect the lhs of the assignment. Prepend is used to ensure that the
10100 nullification occurs before the call to the finalizer. In the case of
10101 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10102 as part of the deep copy. */
10103 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10104 && (gfc_is_alloc_class_array_function (expr2
)
10105 || gfc_is_alloc_class_scalar_function (expr2
)))
10108 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10109 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10110 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10111 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10114 if (is_poly_assign
)
10115 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10116 use_vptr_copy
|| (lhs_attr
.allocatable
10117 && !lhs_attr
.dimension
),
10118 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10119 else if (flag_coarray
== GFC_FCOARRAY_LIB
10120 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10121 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10122 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10124 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10125 allocatable component, because those need to be accessed via the
10126 caf-runtime. No need to check for coindexes here, because resolve
10127 has rewritten those already. */
10129 gfc_actual_arglist a1
, a2
;
10130 /* Clear the structures to prevent accessing garbage. */
10131 memset (&code
, '\0', sizeof (gfc_code
));
10132 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10133 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10138 code
.ext
.actual
= &a1
;
10139 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10140 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10143 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10144 gfc_expr_is_variable (expr2
)
10146 || expr2
->expr_type
== EXPR_ARRAY
,
10147 !(l_is_temp
|| init_flag
) && dealloc
,
10148 expr1
->symtree
->n
.sym
->attr
.codimension
);
10149 /* Add the pre blocks to the body. */
10150 gfc_add_block_to_block (&body
, &rse
.pre
);
10151 gfc_add_block_to_block (&body
, &lse
.pre
);
10152 gfc_add_expr_to_block (&body
, tmp
);
10153 /* Add the post blocks to the body. */
10154 gfc_add_block_to_block (&body
, &rse
.post
);
10155 gfc_add_block_to_block (&body
, &lse
.post
);
10157 if (lss
== gfc_ss_terminator
)
10159 /* F2003: Add the code for reallocation on assignment. */
10160 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10161 && !is_poly_assign
)
10162 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10165 /* Use the scalar assignment as is. */
10166 gfc_add_block_to_block (&block
, &body
);
10170 gcc_assert (lse
.ss
== gfc_ss_terminator
10171 && rse
.ss
== gfc_ss_terminator
);
10175 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10177 /* We need to copy the temporary to the actual lhs. */
10178 gfc_init_se (&lse
, NULL
);
10179 gfc_init_se (&rse
, NULL
);
10180 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10181 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10183 rse
.ss
= loop
.temp_ss
;
10186 gfc_conv_tmp_array_ref (&rse
);
10187 gfc_conv_expr (&lse
, expr1
);
10189 gcc_assert (lse
.ss
== gfc_ss_terminator
10190 && rse
.ss
== gfc_ss_terminator
);
10192 if (expr2
->ts
.type
== BT_CHARACTER
)
10193 rse
.string_length
= string_length
;
10195 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10197 gfc_add_expr_to_block (&body
, tmp
);
10200 /* F2003: Allocate or reallocate lhs of allocatable array. */
10201 if (flag_realloc_lhs
10202 && gfc_is_reallocatable_lhs (expr1
)
10204 && !is_runtime_conformable (expr1
, expr2
))
10206 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10207 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10208 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10209 if (tmp
!= NULL_TREE
)
10210 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10213 if (maybe_workshare
)
10214 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10216 /* Generate the copying loops. */
10217 gfc_trans_scalarizing_loops (&loop
, &body
);
10219 /* Wrap the whole thing up. */
10220 gfc_add_block_to_block (&block
, &loop
.pre
);
10221 gfc_add_block_to_block (&block
, &loop
.post
);
10223 gfc_cleanup_loop (&loop
);
10226 return gfc_finish_block (&block
);
10230 /* Check whether EXPR is a copyable array. */
10233 copyable_array_p (gfc_expr
* expr
)
10235 if (expr
->expr_type
!= EXPR_VARIABLE
)
10238 /* First check it's an array. */
10239 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10242 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10245 /* Next check that it's of a simple enough type. */
10246 switch (expr
->ts
.type
)
10258 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10267 /* Translate an assignment. */
10270 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10271 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10275 /* Special case a single function returning an array. */
10276 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10278 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10283 /* Special case assigning an array to zero. */
10284 if (copyable_array_p (expr1
)
10285 && is_zero_initializer_p (expr2
))
10287 tmp
= gfc_trans_zero_assign (expr1
);
10292 /* Special case copying one array to another. */
10293 if (copyable_array_p (expr1
)
10294 && copyable_array_p (expr2
)
10295 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10296 && !gfc_check_dependency (expr1
, expr2
, 0))
10298 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10303 /* Special case initializing an array from a constant array constructor. */
10304 if (copyable_array_p (expr1
)
10305 && expr2
->expr_type
== EXPR_ARRAY
10306 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10308 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10313 /* Fallback to the scalarizer to generate explicit loops. */
10314 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10315 use_vptr_copy
, may_alias
);
10319 gfc_trans_init_assign (gfc_code
* code
)
10321 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10325 gfc_trans_assign (gfc_code
* code
)
10327 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);