1 /* Expression translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
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 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
964 && (!class_ts
.u
.derived
->components
->as
965 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
968 /* Test for FULL_ARRAY. */
969 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
970 && gfc_expr_attr (e
).dimension
)
973 gfc_is_class_array_ref (e
, &full_array
);
975 /* The derived type needs to be converted to a temporary
977 tmp
= gfc_typenode_for_spec (&class_ts
);
978 var
= gfc_create_var (tmp
, "class");
981 ctree
= gfc_class_data_get (var
);
982 if (class_ts
.u
.derived
->components
->as
983 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
987 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
989 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
990 gfc_get_dtype (type
));
992 tmp
= gfc_class_data_get (parmse
->expr
);
993 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
994 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
996 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
999 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1003 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1004 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1005 TREE_TYPE (ctree
), parmse
->expr
);
1006 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1009 /* Return the data component, except in the case of scalarized array
1010 references, where nullification of the cannot occur and so there
1012 if (!elemental
&& full_array
&& copyback
)
1014 if (class_ts
.u
.derived
->components
->as
1015 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1018 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1019 gfc_conv_descriptor_data_get (ctree
));
1021 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1024 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1028 ctree
= gfc_class_vptr_get (var
);
1030 /* The vptr is the second field of the actual argument.
1031 First we have to find the corresponding class reference. */
1034 if (gfc_is_class_array_function (e
)
1035 && parmse
->class_vptr
!= NULL_TREE
)
1036 tmp
= parmse
->class_vptr
;
1037 else if (class_ref
== NULL
1038 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1040 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1042 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1043 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1045 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1046 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1048 slen
= integer_zero_node
;
1052 /* Remove everything after the last class reference, convert the
1053 expression and then recover its tailend once more. */
1055 ref
= class_ref
->next
;
1056 class_ref
->next
= NULL
;
1057 gfc_init_se (&tmpse
, NULL
);
1058 gfc_conv_expr (&tmpse
, e
);
1059 class_ref
->next
= ref
;
1061 slen
= tmpse
.string_length
;
1064 gcc_assert (tmp
!= NULL_TREE
);
1066 /* Dereference if needs be. */
1067 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1068 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1070 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1071 vptr
= gfc_class_vptr_get (tmp
);
1075 gfc_add_modify (&block
, ctree
,
1076 fold_convert (TREE_TYPE (ctree
), vptr
));
1078 /* Return the vptr component, except in the case of scalarized array
1079 references, where the dynamic type cannot change. */
1080 if (!elemental
&& full_array
&& copyback
)
1081 gfc_add_modify (&parmse
->post
, vptr
,
1082 fold_convert (TREE_TYPE (vptr
), ctree
));
1084 /* For unlimited polymorphic objects also set the _len component. */
1085 if (class_ts
.type
== BT_CLASS
1086 && class_ts
.u
.derived
->components
1087 && class_ts
.u
.derived
->components
->ts
.u
1088 .derived
->attr
.unlimited_polymorphic
)
1090 ctree
= gfc_class_len_get (var
);
1091 if (UNLIMITED_POLY (e
))
1092 tmp
= gfc_class_len_get (tmp
);
1093 else if (e
->ts
.type
== BT_CHARACTER
)
1095 gcc_assert (slen
!= NULL_TREE
);
1099 tmp
= integer_zero_node
;
1100 gfc_add_modify (&parmse
->pre
, ctree
,
1101 fold_convert (TREE_TYPE (ctree
), tmp
));
1103 /* Return the len component, except in the case of scalarized array
1104 references, where the dynamic type cannot change. */
1105 if (!elemental
&& full_array
&& copyback
)
1106 gfc_add_modify (&parmse
->post
, tmp
,
1107 fold_convert (TREE_TYPE (tmp
), ctree
));
1114 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1115 /* parmse->pre may contain some preparatory instructions for the
1116 temporary array descriptor. Those may only be executed when the
1117 optional argument is set, therefore add parmse->pre's instructions
1118 to block, which is later guarded by an if (optional_arg_given). */
1119 gfc_add_block_to_block (&parmse
->pre
, &block
);
1120 block
.head
= parmse
->pre
.head
;
1121 parmse
->pre
.head
= NULL_TREE
;
1122 tmp
= gfc_finish_block (&block
);
1124 if (optional_alloc_ptr
)
1125 tmp2
= build_empty_stmt (input_location
);
1128 gfc_init_block (&block
);
1130 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1131 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1132 null_pointer_node
));
1133 tmp2
= gfc_finish_block (&block
);
1136 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1138 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1141 gfc_add_block_to_block (&parmse
->pre
, &block
);
1143 /* Pass the address of the class object. */
1144 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1146 if (optional
&& optional_alloc_ptr
)
1147 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1148 TREE_TYPE (parmse
->expr
),
1150 fold_convert (TREE_TYPE (parmse
->expr
),
1151 null_pointer_node
));
1155 /* Given a class array declaration and an index, returns the address
1156 of the referenced element. */
1159 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1161 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1162 gfc_class_data_get (class_decl
);
1163 tree size
= gfc_class_vtab_size_get (class_decl
);
1164 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1165 gfc_array_index_type
,
1168 data
= gfc_conv_descriptor_data_get (data
);
1169 ptr
= fold_convert (pvoid_type_node
, data
);
1170 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1171 return fold_convert (TREE_TYPE (data
), ptr
);
1175 /* Copies one class expression to another, assuming that if either
1176 'to' or 'from' are arrays they are packed. Should 'from' be
1177 NULL_TREE, the initialization expression for 'to' is used, assuming
1178 that the _vptr is set. */
1181 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1191 vec
<tree
, va_gc
> *args
;
1196 bool is_from_desc
= false, is_to_class
= false;
1199 /* To prevent warnings on uninitialized variables. */
1200 from_len
= to_len
= NULL_TREE
;
1202 if (from
!= NULL_TREE
)
1203 fcn
= gfc_class_vtab_copy_get (from
);
1205 fcn
= gfc_class_vtab_copy_get (to
);
1207 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1209 if (from
!= NULL_TREE
)
1211 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1215 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1219 /* Check that from is a class. When the class is part of a coarray,
1220 then from is a common pointer and is to be used as is. */
1221 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1222 ? build_fold_indirect_ref (from
) : from
;
1224 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1225 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1226 ? gfc_class_data_get (from
) : from
;
1227 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1231 from_data
= gfc_class_vtab_def_init_get (to
);
1235 if (from
!= NULL_TREE
&& unlimited
)
1236 from_len
= gfc_class_len_or_zero_get (from
);
1238 from_len
= integer_zero_node
;
1241 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1244 to_data
= gfc_class_data_get (to
);
1246 to_len
= gfc_class_len_get (to
);
1249 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1252 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1254 stmtblock_t loopbody
;
1258 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1260 gfc_init_block (&body
);
1261 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1262 gfc_array_index_type
, nelems
,
1263 gfc_index_one_node
);
1264 nelems
= gfc_evaluate_now (tmp
, &body
);
1265 index
= gfc_create_var (gfc_array_index_type
, "S");
1269 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1270 vec_safe_push (args
, from_ref
);
1273 vec_safe_push (args
, from_data
);
1276 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1279 tmp
= gfc_conv_array_data (to
);
1280 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1281 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1282 gfc_build_array_ref (tmp
, index
, to
));
1284 vec_safe_push (args
, to_ref
);
1286 /* Add bounds check. */
1287 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1290 const char *name
= "<<unknown>>";
1294 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1296 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1297 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1298 logical_type_node
, from_len
, orig_nelems
);
1299 msg
= xasprintf ("Array bound mismatch for dimension %d "
1300 "of array '%s' (%%ld/%%ld)",
1303 gfc_trans_runtime_check (true, false, tmp
, &body
,
1304 &gfc_current_locus
, msg
,
1305 fold_convert (long_integer_type_node
, orig_nelems
),
1306 fold_convert (long_integer_type_node
, from_len
));
1311 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1313 /* Build the body of the loop. */
1314 gfc_init_block (&loopbody
);
1315 gfc_add_expr_to_block (&loopbody
, tmp
);
1317 /* Build the loop and return. */
1318 gfc_init_loopinfo (&loop
);
1320 loop
.from
[0] = gfc_index_zero_node
;
1321 loop
.loopvar
[0] = index
;
1322 loop
.to
[0] = nelems
;
1323 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1324 gfc_init_block (&ifbody
);
1325 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1326 stdcopy
= gfc_finish_block (&ifbody
);
1327 /* In initialization mode from_len is a constant zero. */
1328 if (unlimited
&& !integer_zerop (from_len
))
1330 vec_safe_push (args
, from_len
);
1331 vec_safe_push (args
, to_len
);
1332 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1333 /* Build the body of the loop. */
1334 gfc_init_block (&loopbody
);
1335 gfc_add_expr_to_block (&loopbody
, tmp
);
1337 /* Build the loop and return. */
1338 gfc_init_loopinfo (&loop
);
1340 loop
.from
[0] = gfc_index_zero_node
;
1341 loop
.loopvar
[0] = index
;
1342 loop
.to
[0] = nelems
;
1343 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1344 gfc_init_block (&ifbody
);
1345 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1346 extcopy
= gfc_finish_block (&ifbody
);
1348 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1349 logical_type_node
, from_len
,
1351 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1352 void_type_node
, tmp
, extcopy
, stdcopy
);
1353 gfc_add_expr_to_block (&body
, tmp
);
1354 tmp
= gfc_finish_block (&body
);
1358 gfc_add_expr_to_block (&body
, stdcopy
);
1359 tmp
= gfc_finish_block (&body
);
1361 gfc_cleanup_loop (&loop
);
1365 gcc_assert (!is_from_desc
);
1366 vec_safe_push (args
, from_data
);
1367 vec_safe_push (args
, to_data
);
1368 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1370 /* In initialization mode from_len is a constant zero. */
1371 if (unlimited
&& !integer_zerop (from_len
))
1373 vec_safe_push (args
, from_len
);
1374 vec_safe_push (args
, to_len
);
1375 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1376 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1377 logical_type_node
, from_len
,
1379 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1380 void_type_node
, tmp
, extcopy
, stdcopy
);
1386 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1387 if (from
== NULL_TREE
)
1390 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1392 from_data
, null_pointer_node
);
1393 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1394 void_type_node
, cond
,
1395 tmp
, build_empty_stmt (input_location
));
1403 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1405 gfc_actual_arglist
*actual
;
1410 actual
= gfc_get_actual_arglist ();
1411 actual
->expr
= gfc_copy_expr (rhs
);
1412 actual
->next
= gfc_get_actual_arglist ();
1413 actual
->next
->expr
= gfc_copy_expr (lhs
);
1414 ppc
= gfc_copy_expr (obj
);
1415 gfc_add_vptr_component (ppc
);
1416 gfc_add_component_ref (ppc
, "_copy");
1417 ppc_code
= gfc_get_code (EXEC_CALL
);
1418 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1419 /* Although '_copy' is set to be elemental in class.c, it is
1420 not staying that way. Find out why, sometime.... */
1421 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1422 ppc_code
->ext
.actual
= actual
;
1423 ppc_code
->expr1
= ppc
;
1424 /* Since '_copy' is elemental, the scalarizer will take care
1425 of arrays in gfc_trans_call. */
1426 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1427 gfc_free_statements (ppc_code
);
1429 if (UNLIMITED_POLY(obj
))
1431 /* Check if rhs is non-NULL. */
1433 gfc_init_se (&src
, NULL
);
1434 gfc_conv_expr (&src
, rhs
);
1435 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1436 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1437 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1438 null_pointer_node
));
1439 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1440 build_empty_stmt (input_location
));
1446 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1447 A MEMCPY is needed to copy the full data from the default initializer
1448 of the dynamic type. */
1451 gfc_trans_class_init_assign (gfc_code
*code
)
1455 gfc_se dst
,src
,memsz
;
1456 gfc_expr
*lhs
, *rhs
, *sz
;
1458 gfc_start_block (&block
);
1460 lhs
= gfc_copy_expr (code
->expr1
);
1461 gfc_add_data_component (lhs
);
1463 rhs
= gfc_copy_expr (code
->expr1
);
1464 gfc_add_vptr_component (rhs
);
1466 /* Make sure that the component backend_decls have been built, which
1467 will not have happened if the derived types concerned have not
1469 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1470 gfc_add_def_init_component (rhs
);
1471 /* The _def_init is always scalar. */
1474 if (code
->expr1
->ts
.type
== BT_CLASS
1475 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1477 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1478 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1479 gfc_add_full_array_ref (lhs
, tmparr
);
1480 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1484 sz
= gfc_copy_expr (code
->expr1
);
1485 gfc_add_vptr_component (sz
);
1486 gfc_add_size_component (sz
);
1488 gfc_init_se (&dst
, NULL
);
1489 gfc_init_se (&src
, NULL
);
1490 gfc_init_se (&memsz
, NULL
);
1491 gfc_conv_expr (&dst
, lhs
);
1492 gfc_conv_expr (&src
, rhs
);
1493 gfc_conv_expr (&memsz
, sz
);
1494 gfc_add_block_to_block (&block
, &src
.pre
);
1495 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1497 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1499 if (UNLIMITED_POLY(code
->expr1
))
1501 /* Check if _def_init is non-NULL. */
1502 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1503 logical_type_node
, src
.expr
,
1504 fold_convert (TREE_TYPE (src
.expr
),
1505 null_pointer_node
));
1506 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1507 tmp
, build_empty_stmt (input_location
));
1511 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1512 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1514 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1515 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1517 build_empty_stmt (input_location
));
1520 gfc_add_expr_to_block (&block
, tmp
);
1522 return gfc_finish_block (&block
);
1526 /* End of prototype trans-class.c */
1530 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1532 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1533 gfc_warning (OPT_Wrealloc_lhs
,
1534 "Code for reallocating the allocatable array at %L will "
1536 else if (warn_realloc_lhs_all
)
1537 gfc_warning (OPT_Wrealloc_lhs_all
,
1538 "Code for reallocating the allocatable variable at %L "
1539 "will be added", where
);
1543 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1546 /* Copy the scalarization loop variables. */
1549 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1552 dest
->loop
= src
->loop
;
1556 /* Initialize a simple expression holder.
1558 Care must be taken when multiple se are created with the same parent.
1559 The child se must be kept in sync. The easiest way is to delay creation
1560 of a child se until after after the previous se has been translated. */
1563 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1565 memset (se
, 0, sizeof (gfc_se
));
1566 gfc_init_block (&se
->pre
);
1567 gfc_init_block (&se
->post
);
1569 se
->parent
= parent
;
1572 gfc_copy_se_loopvars (se
, parent
);
1576 /* Advances to the next SS in the chain. Use this rather than setting
1577 se->ss = se->ss->next because all the parents needs to be kept in sync.
1581 gfc_advance_se_ss_chain (gfc_se
* se
)
1586 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1589 /* Walk down the parent chain. */
1592 /* Simple consistency check. */
1593 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1594 || p
->parent
->ss
->nested_ss
== p
->ss
);
1596 /* If we were in a nested loop, the next scalarized expression can be
1597 on the parent ss' next pointer. Thus we should not take the next
1598 pointer blindly, but rather go up one nest level as long as next
1599 is the end of chain. */
1601 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1611 /* Ensures the result of the expression as either a temporary variable
1612 or a constant so that it can be used repeatedly. */
1615 gfc_make_safe_expr (gfc_se
* se
)
1619 if (CONSTANT_CLASS_P (se
->expr
))
1622 /* We need a temporary for this result. */
1623 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1624 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1629 /* Return an expression which determines if a dummy parameter is present.
1630 Also used for arguments to procedures with multiple entry points. */
1633 gfc_conv_expr_present (gfc_symbol
* sym
)
1637 gcc_assert (sym
->attr
.dummy
);
1638 decl
= gfc_get_symbol_decl (sym
);
1640 /* Intrinsic scalars with VALUE attribute which are passed by value
1641 use a hidden argument to denote the present status. */
1642 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1643 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1644 && !sym
->attr
.dimension
)
1646 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1649 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1651 strcpy (&name
[1], sym
->name
);
1652 tree_name
= get_identifier (name
);
1654 /* Walk function argument list to find hidden arg. */
1655 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1656 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1657 if (DECL_NAME (cond
) == tree_name
)
1664 if (TREE_CODE (decl
) != PARM_DECL
)
1666 /* Array parameters use a temporary descriptor, we want the real
1668 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1669 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1670 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1673 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1674 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1676 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1677 as actual argument to denote absent dummies. For array descriptors,
1678 we thus also need to check the array descriptor. For BT_CLASS, it
1679 can also occur for scalars and F2003 due to type->class wrapping and
1680 class->class wrapping. Note further that BT_CLASS always uses an
1681 array descriptor for arrays, also for explicit-shape/assumed-size. */
1683 if (!sym
->attr
.allocatable
1684 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1685 || (sym
->ts
.type
== BT_CLASS
1686 && !CLASS_DATA (sym
)->attr
.allocatable
1687 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1688 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1689 || sym
->ts
.type
== BT_CLASS
))
1693 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1694 || sym
->as
->type
== AS_ASSUMED_RANK
1695 || sym
->attr
.codimension
))
1696 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1698 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1699 if (sym
->ts
.type
== BT_CLASS
)
1700 tmp
= gfc_class_data_get (tmp
);
1701 tmp
= gfc_conv_array_data (tmp
);
1703 else if (sym
->ts
.type
== BT_CLASS
)
1704 tmp
= gfc_class_data_get (decl
);
1708 if (tmp
!= NULL_TREE
)
1710 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1711 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1712 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1713 logical_type_node
, cond
, tmp
);
1721 /* Converts a missing, dummy argument into a null or zero. */
1724 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1729 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1733 /* Create a temporary and convert it to the correct type. */
1734 tmp
= gfc_get_int_type (kind
);
1735 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1738 /* Test for a NULL value. */
1739 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1740 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1741 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1742 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1746 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1748 build_zero_cst (TREE_TYPE (se
->expr
)));
1749 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1753 if (ts
.type
== BT_CHARACTER
)
1755 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1756 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1757 present
, se
->string_length
, tmp
);
1758 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1759 se
->string_length
= tmp
;
1765 /* Get the character length of an expression, looking through gfc_refs
1769 gfc_get_expr_charlen (gfc_expr
*e
)
1774 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1775 && e
->ts
.type
== BT_CHARACTER
);
1777 length
= NULL
; /* To silence compiler warning. */
1779 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1782 gfc_init_se (&tmpse
, NULL
);
1783 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1784 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1788 /* First candidate: if the variable is of type CHARACTER, the
1789 expression's length could be the length of the character
1791 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1792 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1794 /* Look through the reference chain for component references. */
1795 for (r
= e
->ref
; r
; r
= r
->next
)
1800 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1801 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1809 /* We should never got substring references here. These will be
1810 broken down by the scalarizer. */
1816 gcc_assert (length
!= NULL
);
1821 /* Return for an expression the backend decl of the coarray. */
1824 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1830 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1832 /* Not-implemented diagnostic. */
1833 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1834 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1835 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1836 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1837 "%L is not supported", &expr
->where
);
1839 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1840 if (ref
->type
== REF_COMPONENT
)
1842 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1843 && UNLIMITED_POLY (ref
->u
.c
.component
)
1844 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1845 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1846 "component at %L is not supported", &expr
->where
);
1849 /* Make sure the backend_decl is present before accessing it. */
1850 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1851 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1852 : expr
->symtree
->n
.sym
->backend_decl
;
1854 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1856 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1858 caf_decl
= gfc_class_data_get (caf_decl
);
1859 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1862 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1864 if (ref
->type
== REF_COMPONENT
1865 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1867 caf_decl
= gfc_class_data_get (caf_decl
);
1868 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1872 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1876 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1879 /* The following code assumes that the coarray is a component reachable via
1880 only scalar components/variables; the Fortran standard guarantees this. */
1882 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1883 if (ref
->type
== REF_COMPONENT
)
1885 gfc_component
*comp
= ref
->u
.c
.component
;
1887 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1888 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1889 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1890 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1891 comp
->backend_decl
, NULL_TREE
);
1892 if (comp
->ts
.type
== BT_CLASS
)
1894 caf_decl
= gfc_class_data_get (caf_decl
);
1895 if (CLASS_DATA (comp
)->attr
.codimension
)
1901 if (comp
->attr
.codimension
)
1907 gcc_assert (found
&& caf_decl
);
1912 /* Obtain the Coarray token - and optionally also the offset. */
1915 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1916 tree se_expr
, gfc_expr
*expr
)
1920 /* Coarray token. */
1921 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1923 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1924 == GFC_ARRAY_ALLOCATABLE
1925 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1926 *token
= gfc_conv_descriptor_token (caf_decl
);
1928 else if (DECL_LANG_SPECIFIC (caf_decl
)
1929 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1930 *token
= GFC_DECL_TOKEN (caf_decl
);
1933 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1934 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1935 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1941 /* Offset between the coarray base address and the address wanted. */
1942 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1943 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1944 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1945 *offset
= build_int_cst (gfc_array_index_type
, 0);
1946 else if (DECL_LANG_SPECIFIC (caf_decl
)
1947 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1948 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1949 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1950 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1952 *offset
= build_int_cst (gfc_array_index_type
, 0);
1954 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1955 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1957 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1958 tmp
= gfc_conv_descriptor_data_get (tmp
);
1960 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1961 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1964 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1968 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1969 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1971 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1972 && expr
->symtree
->n
.sym
->attr
.codimension
1973 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
1975 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
1976 gfc_ref
*ref
= base_expr
->ref
;
1979 // Iterate through the refs until the last one.
1983 if (ref
->type
== REF_ARRAY
1984 && ref
->u
.ar
.type
!= AR_FULL
)
1986 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
1988 for (i
= 0; i
< ranksum
; ++i
)
1990 ref
->u
.ar
.start
[i
] = NULL
;
1991 ref
->u
.ar
.end
[i
] = NULL
;
1993 ref
->u
.ar
.type
= AR_FULL
;
1995 gfc_init_se (&base_se
, NULL
);
1996 if (gfc_caf_attr (base_expr
).dimension
)
1998 gfc_conv_expr_descriptor (&base_se
, base_expr
);
1999 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2003 gfc_conv_expr (&base_se
, base_expr
);
2007 gfc_free_expr (base_expr
);
2008 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2009 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2011 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2012 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2019 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2020 fold_convert (gfc_array_index_type
, *offset
),
2021 fold_convert (gfc_array_index_type
, tmp
));
2025 /* Convert the coindex of a coarray into an image index; the result is
2026 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2027 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2030 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2033 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2037 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2038 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2040 gcc_assert (ref
!= NULL
);
2042 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2044 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2048 img_idx
= integer_zero_node
;
2049 extent
= integer_one_node
;
2050 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2051 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2053 gfc_init_se (&se
, NULL
);
2054 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2055 gfc_add_block_to_block (block
, &se
.pre
);
2056 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2057 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2058 integer_type_node
, se
.expr
,
2059 fold_convert(integer_type_node
, lbound
));
2060 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2062 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2064 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2066 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2067 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2068 tmp
= fold_convert (integer_type_node
, tmp
);
2069 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2070 integer_type_node
, extent
, tmp
);
2074 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2076 gfc_init_se (&se
, NULL
);
2077 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2078 gfc_add_block_to_block (block
, &se
.pre
);
2079 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2080 lbound
= fold_convert (integer_type_node
, lbound
);
2081 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2082 integer_type_node
, se
.expr
, lbound
);
2083 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2085 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2087 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2089 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2090 ubound
= fold_convert (integer_type_node
, ubound
);
2091 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2092 integer_type_node
, ubound
, lbound
);
2093 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2094 tmp
, integer_one_node
);
2095 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2096 integer_type_node
, extent
, tmp
);
2099 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2100 img_idx
, integer_one_node
);
2105 /* For each character array constructor subexpression without a ts.u.cl->length,
2106 replace it by its first element (if there aren't any elements, the length
2107 should already be set to zero). */
2110 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2112 gfc_actual_arglist
* arg
;
2118 switch (e
->expr_type
)
2122 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2123 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2127 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2131 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2132 flatten_array_ctors_without_strlen (arg
->expr
);
2137 /* We've found what we're looking for. */
2138 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2143 gcc_assert (e
->value
.constructor
);
2145 c
= gfc_constructor_first (e
->value
.constructor
);
2149 flatten_array_ctors_without_strlen (new_expr
);
2150 gfc_replace_expr (e
, new_expr
);
2154 /* Otherwise, fall through to handle constructor elements. */
2156 case EXPR_STRUCTURE
:
2157 for (c
= gfc_constructor_first (e
->value
.constructor
);
2158 c
; c
= gfc_constructor_next (c
))
2159 flatten_array_ctors_without_strlen (c
->expr
);
2169 /* Generate code to initialize a string length variable. Returns the
2170 value. For array constructors, cl->length might be NULL and in this case,
2171 the first element of the constructor is needed. expr is the original
2172 expression so we can access it but can be NULL if this is not needed. */
2175 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2179 gfc_init_se (&se
, NULL
);
2181 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2184 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2185 "flatten" array constructors by taking their first element; all elements
2186 should be the same length or a cl->length should be present. */
2189 gfc_expr
* expr_flat
;
2191 expr_flat
= gfc_copy_expr (expr
);
2192 flatten_array_ctors_without_strlen (expr_flat
);
2193 gfc_resolve_expr (expr_flat
);
2195 gfc_conv_expr (&se
, expr_flat
);
2196 gfc_add_block_to_block (pblock
, &se
.pre
);
2197 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2199 gfc_free_expr (expr_flat
);
2203 /* Convert cl->length. */
2205 gcc_assert (cl
->length
);
2207 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2208 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2209 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2210 gfc_add_block_to_block (pblock
, &se
.pre
);
2212 if (cl
->backend_decl
)
2213 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2215 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2220 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2221 const char *name
, locus
*where
)
2231 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2232 type
= build_pointer_type (type
);
2234 gfc_init_se (&start
, se
);
2235 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2236 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2238 if (integer_onep (start
.expr
))
2239 gfc_conv_string_parameter (se
);
2244 /* Avoid multiple evaluation of substring start. */
2245 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2246 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2248 /* Change the start of the string. */
2249 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2252 tmp
= build_fold_indirect_ref_loc (input_location
,
2254 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2255 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2258 /* Length = end + 1 - start. */
2259 gfc_init_se (&end
, se
);
2260 if (ref
->u
.ss
.end
== NULL
)
2261 end
.expr
= se
->string_length
;
2264 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2265 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2269 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2270 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2272 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2274 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2275 logical_type_node
, start
.expr
,
2278 /* Check lower bound. */
2279 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2281 build_int_cst (gfc_charlen_type_node
, 1));
2282 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2283 logical_type_node
, nonempty
, fault
);
2285 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2286 "is less than one", name
);
2288 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2289 "is less than one");
2290 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2291 fold_convert (long_integer_type_node
,
2295 /* Check upper bound. */
2296 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2297 end
.expr
, se
->string_length
);
2298 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2299 logical_type_node
, nonempty
, fault
);
2301 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2302 "exceeds string length (%%ld)", name
);
2304 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2305 "exceeds string length (%%ld)");
2306 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2307 fold_convert (long_integer_type_node
, end
.expr
),
2308 fold_convert (long_integer_type_node
,
2309 se
->string_length
));
2313 /* Try to calculate the length from the start and end expressions. */
2315 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2319 i_len
= mpz_get_si (length
) + 1;
2323 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2324 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2329 end
.expr
, start
.expr
);
2330 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2331 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2332 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2333 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2336 se
->string_length
= tmp
;
2340 /* Convert a derived type component reference. */
2343 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2351 c
= ref
->u
.c
.component
;
2353 if (c
->backend_decl
== NULL_TREE
2354 && ref
->u
.c
.sym
!= NULL
)
2355 gfc_get_derived_type (ref
->u
.c
.sym
);
2357 field
= c
->backend_decl
;
2358 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2360 context
= DECL_FIELD_CONTEXT (field
);
2362 /* Components can correspond to fields of different containing
2363 types, as components are created without context, whereas
2364 a concrete use of a component has the type of decl as context.
2365 So, if the type doesn't match, we search the corresponding
2366 FIELD_DECL in the parent type. To not waste too much time
2367 we cache this result in norestrict_decl.
2368 On the other hand, if the context is a UNION or a MAP (a
2369 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2371 if (context
!= TREE_TYPE (decl
)
2372 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2373 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2375 tree f2
= c
->norestrict_decl
;
2376 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2377 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2378 if (TREE_CODE (f2
) == FIELD_DECL
2379 && DECL_NAME (f2
) == DECL_NAME (field
))
2382 c
->norestrict_decl
= f2
;
2386 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2387 && strcmp ("_data", c
->name
) == 0)
2389 /* Found a ref to the _data component. Store the associated ref to
2390 the vptr in se->class_vptr. */
2391 se
->class_vptr
= gfc_class_vptr_get (decl
);
2394 se
->class_vptr
= NULL_TREE
;
2396 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2397 decl
, field
, NULL_TREE
);
2401 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2402 strlen () conditional below. */
2403 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2404 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2405 && !c
->attr
.pdt_string
)
2407 tmp
= c
->ts
.u
.cl
->backend_decl
;
2408 /* Components must always be constant length. */
2409 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2410 se
->string_length
= tmp
;
2413 if (gfc_deferred_strlen (c
, &field
))
2415 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2417 decl
, field
, NULL_TREE
);
2418 se
->string_length
= tmp
;
2421 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2422 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2423 && c
->ts
.type
!= BT_CHARACTER
)
2424 || c
->attr
.proc_pointer
)
2425 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2430 /* This function deals with component references to components of the
2431 parent type for derived type extensions. */
2433 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2441 c
= ref
->u
.c
.component
;
2443 /* Return if the component is in the parent type. */
2444 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2445 if (strcmp (c
->name
, cmp
->name
) == 0)
2448 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2449 parent
.type
= REF_COMPONENT
;
2451 parent
.u
.c
.sym
= dt
;
2452 parent
.u
.c
.component
= dt
->components
;
2454 if (dt
->backend_decl
== NULL
)
2455 gfc_get_derived_type (dt
);
2457 /* Build the reference and call self. */
2458 gfc_conv_component_ref (se
, &parent
);
2459 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2460 parent
.u
.c
.component
= c
;
2461 conv_parent_component_references (se
, &parent
);
2464 /* Return the contents of a variable. Also handles reference/pointer
2465 variables (all Fortran pointer references are implicit). */
2468 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2473 tree parent_decl
= NULL_TREE
;
2476 bool alternate_entry
;
2479 bool first_time
= true;
2481 sym
= expr
->symtree
->n
.sym
;
2482 is_classarray
= IS_CLASS_ARRAY (sym
);
2486 gfc_ss_info
*ss_info
= ss
->info
;
2488 /* Check that something hasn't gone horribly wrong. */
2489 gcc_assert (ss
!= gfc_ss_terminator
);
2490 gcc_assert (ss_info
->expr
== expr
);
2492 /* A scalarized term. We already know the descriptor. */
2493 se
->expr
= ss_info
->data
.array
.descriptor
;
2494 se
->string_length
= ss_info
->string_length
;
2495 ref
= ss_info
->data
.array
.ref
;
2497 gcc_assert (ref
->type
== REF_ARRAY
2498 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2500 gfc_conv_tmp_array_ref (se
);
2504 tree se_expr
= NULL_TREE
;
2506 se
->expr
= gfc_get_symbol_decl (sym
);
2508 /* Deal with references to a parent results or entries by storing
2509 the current_function_decl and moving to the parent_decl. */
2510 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2511 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2512 && sym
->result
== sym
;
2513 entry_master
= sym
->attr
.result
2514 && sym
->ns
->proc_name
->attr
.entry_master
2515 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2516 if (current_function_decl
)
2517 parent_decl
= DECL_CONTEXT (current_function_decl
);
2519 if ((se
->expr
== parent_decl
&& return_value
)
2520 || (sym
->ns
&& sym
->ns
->proc_name
2522 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2523 && (alternate_entry
|| entry_master
)))
2528 /* Special case for assigning the return value of a function.
2529 Self recursive functions must have an explicit return value. */
2530 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2531 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2533 /* Similarly for alternate entry points. */
2534 else if (alternate_entry
2535 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2538 gfc_entry_list
*el
= NULL
;
2540 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2543 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2548 else if (entry_master
2549 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2551 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2556 /* Procedure actual arguments. Look out for temporary variables
2557 with the same attributes as function values. */
2558 else if (!sym
->attr
.temporary
2559 && sym
->attr
.flavor
== FL_PROCEDURE
2560 && se
->expr
!= current_function_decl
)
2562 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2564 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2565 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2571 /* Dereference the expression, where needed. Since characters
2572 are entirely different from other types, they are treated
2574 if (sym
->ts
.type
== BT_CHARACTER
)
2576 /* Dereference character pointer dummy arguments
2578 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2580 || sym
->attr
.function
2581 || sym
->attr
.result
))
2582 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2586 else if (!sym
->attr
.value
)
2588 /* Dereference temporaries for class array dummy arguments. */
2589 if (sym
->attr
.dummy
&& is_classarray
2590 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2592 if (!se
->descriptor_only
)
2593 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2595 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2599 /* Dereference non-character scalar dummy arguments. */
2600 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2601 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2602 && (sym
->ts
.type
!= BT_CLASS
2603 || (!CLASS_DATA (sym
)->attr
.dimension
2604 && !(CLASS_DATA (sym
)->attr
.codimension
2605 && CLASS_DATA (sym
)->attr
.allocatable
))))
2606 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2609 /* Dereference scalar hidden result. */
2610 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2611 && (sym
->attr
.function
|| sym
->attr
.result
)
2612 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2613 && !sym
->attr
.always_explicit
)
2614 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2617 /* Dereference non-character, non-class pointer variables.
2618 These must be dummies, results, or scalars. */
2620 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2621 || gfc_is_associate_pointer (sym
)
2622 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2624 || sym
->attr
.function
2626 || (!sym
->attr
.dimension
2627 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2628 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2630 /* Now treat the class array pointer variables accordingly. */
2631 else if (sym
->ts
.type
== BT_CLASS
2633 && (CLASS_DATA (sym
)->attr
.dimension
2634 || CLASS_DATA (sym
)->attr
.codimension
)
2635 && ((CLASS_DATA (sym
)->as
2636 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2637 || CLASS_DATA (sym
)->attr
.allocatable
2638 || CLASS_DATA (sym
)->attr
.class_pointer
))
2639 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2641 /* And the case where a non-dummy, non-result, non-function,
2642 non-allotable and non-pointer classarray is present. This case was
2643 previously covered by the first if, but with introducing the
2644 condition !is_classarray there, that case has to be covered
2646 else if (sym
->ts
.type
== BT_CLASS
2648 && !sym
->attr
.function
2649 && !sym
->attr
.result
2650 && (CLASS_DATA (sym
)->attr
.dimension
2651 || CLASS_DATA (sym
)->attr
.codimension
)
2653 || !CLASS_DATA (sym
)->attr
.allocatable
)
2654 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2655 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2662 /* For character variables, also get the length. */
2663 if (sym
->ts
.type
== BT_CHARACTER
)
2665 /* If the character length of an entry isn't set, get the length from
2666 the master function instead. */
2667 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2668 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2670 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2671 gcc_assert (se
->string_length
);
2679 /* Return the descriptor if that's what we want and this is an array
2680 section reference. */
2681 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2683 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2684 /* Return the descriptor for array pointers and allocations. */
2685 if (se
->want_pointer
2686 && ref
->next
== NULL
&& (se
->descriptor_only
))
2689 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2690 /* Return a pointer to an element. */
2694 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2695 && se
->descriptor_only
2696 && !CLASS_DATA (sym
)->attr
.allocatable
2697 && !CLASS_DATA (sym
)->attr
.class_pointer
2698 && CLASS_DATA (sym
)->as
2699 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2700 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2701 /* Skip the first ref of a _data component, because for class
2702 arrays that one is already done by introducing a temporary
2703 array descriptor. */
2706 if (ref
->u
.c
.sym
->attr
.extension
)
2707 conv_parent_component_references (se
, ref
);
2709 gfc_conv_component_ref (se
, ref
);
2710 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2711 && se
->want_pointer
&& se
->descriptor_only
)
2717 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2718 expr
->symtree
->name
, &expr
->where
);
2728 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2730 if (se
->want_pointer
)
2732 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2733 gfc_conv_string_parameter (se
);
2735 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2740 /* Unary ops are easy... Or they would be if ! was a valid op. */
2743 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2748 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2749 /* Initialize the operand. */
2750 gfc_init_se (&operand
, se
);
2751 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2752 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2754 type
= gfc_typenode_for_spec (&expr
->ts
);
2756 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2757 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2758 All other unary operators have an equivalent GIMPLE unary operator. */
2759 if (code
== TRUTH_NOT_EXPR
)
2760 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2761 build_int_cst (type
, 0));
2763 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2767 /* Expand power operator to optimal multiplications when a value is raised
2768 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2769 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2770 Programming", 3rd Edition, 1998. */
2772 /* This code is mostly duplicated from expand_powi in the backend.
2773 We establish the "optimal power tree" lookup table with the defined size.
2774 The items in the table are the exponents used to calculate the index
2775 exponents. Any integer n less than the value can get an "addition chain",
2776 with the first node being one. */
2777 #define POWI_TABLE_SIZE 256
2779 /* The table is from builtins.c. */
2780 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2782 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2783 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2784 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2785 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2786 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2787 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2788 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2789 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2790 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2791 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2792 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2793 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2794 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2795 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2796 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2797 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2798 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2799 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2800 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2801 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2802 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2803 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2804 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2805 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2806 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2807 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2808 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2809 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2810 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2811 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2812 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2813 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2816 /* If n is larger than lookup table's max index, we use the "window
2818 #define POWI_WINDOW_SIZE 3
2820 /* Recursive function to expand the power operator. The temporary
2821 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2823 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2830 if (n
< POWI_TABLE_SIZE
)
2835 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2836 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2840 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2841 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2842 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2846 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2850 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2851 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2853 if (n
< POWI_TABLE_SIZE
)
2860 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2861 return 1. Else return 0 and a call to runtime library functions
2862 will have to be built. */
2864 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2869 tree vartmp
[POWI_TABLE_SIZE
];
2871 unsigned HOST_WIDE_INT n
;
2873 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2875 /* If exponent is too large, we won't expand it anyway, so don't bother
2876 with large integer values. */
2877 if (!wi::fits_shwi_p (wrhs
))
2880 m
= wrhs
.to_shwi ();
2881 /* Use the wide_int's routine to reliably get the absolute value on all
2882 platforms. Then convert it to a HOST_WIDE_INT like above. */
2883 n
= wi::abs (wrhs
).to_shwi ();
2885 type
= TREE_TYPE (lhs
);
2886 sgn
= tree_int_cst_sgn (rhs
);
2888 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2889 || optimize_size
) && (m
> 2 || m
< -1))
2895 se
->expr
= gfc_build_const (type
, integer_one_node
);
2899 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2900 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2902 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2903 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2904 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2905 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2908 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2911 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2912 logical_type_node
, tmp
, cond
);
2913 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2914 tmp
, build_int_cst (type
, 1),
2915 build_int_cst (type
, 0));
2919 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2920 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2921 build_int_cst (type
, -1),
2922 build_int_cst (type
, 0));
2923 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2924 cond
, build_int_cst (type
, 1), tmp
);
2928 memset (vartmp
, 0, sizeof (vartmp
));
2932 tmp
= gfc_build_const (type
, integer_one_node
);
2933 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2937 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2943 /* Power op (**). Constant integer exponent has special handling. */
2946 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2948 tree gfc_int4_type_node
;
2951 int res_ikind_1
, res_ikind_2
;
2956 gfc_init_se (&lse
, se
);
2957 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2958 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2959 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2961 gfc_init_se (&rse
, se
);
2962 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2963 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2965 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2966 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2967 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2970 gfc_int4_type_node
= gfc_get_int_type (4);
2972 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2973 library routine. But in the end, we have to convert the result back
2974 if this case applies -- with res_ikind_K, we keep track whether operand K
2975 falls into this case. */
2979 kind
= expr
->value
.op
.op1
->ts
.kind
;
2980 switch (expr
->value
.op
.op2
->ts
.type
)
2983 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2988 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2989 res_ikind_2
= ikind
;
3011 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3013 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3040 switch (expr
->value
.op
.op1
->ts
.type
)
3043 if (kind
== 3) /* Case 16 was not handled properly above. */
3045 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3049 /* Use builtins for real ** int4. */
3055 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3059 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3063 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3067 /* Use the __builtin_powil() only if real(kind=16) is
3068 actually the C long double type. */
3069 if (!gfc_real16_is_float128
)
3070 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3078 /* If we don't have a good builtin for this, go for the
3079 library function. */
3081 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3085 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3094 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3098 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3106 se
->expr
= build_call_expr_loc (input_location
,
3107 fndecl
, 2, lse
.expr
, rse
.expr
);
3109 /* Convert the result back if it is of wrong integer kind. */
3110 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3112 /* We want the maximum of both operand kinds as result. */
3113 if (res_ikind_1
< res_ikind_2
)
3114 res_ikind_1
= res_ikind_2
;
3115 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3120 /* Generate code to allocate a string temporary. */
3123 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3128 if (gfc_can_put_var_on_stack (len
))
3130 /* Create a temporary variable to hold the result. */
3131 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3132 gfc_charlen_type_node
, len
,
3133 build_int_cst (gfc_charlen_type_node
, 1));
3134 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3136 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3137 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3139 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3141 var
= gfc_create_var (tmp
, "str");
3142 var
= gfc_build_addr_expr (type
, var
);
3146 /* Allocate a temporary to hold the result. */
3147 var
= gfc_create_var (type
, "pstr");
3148 gcc_assert (POINTER_TYPE_P (type
));
3149 tmp
= TREE_TYPE (type
);
3150 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3151 tmp
= TREE_TYPE (tmp
);
3152 tmp
= TYPE_SIZE_UNIT (tmp
);
3153 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3154 fold_convert (size_type_node
, len
),
3155 fold_convert (size_type_node
, tmp
));
3156 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3157 gfc_add_modify (&se
->pre
, var
, tmp
);
3159 /* Free the temporary afterwards. */
3160 tmp
= gfc_call_free (var
);
3161 gfc_add_expr_to_block (&se
->post
, tmp
);
3168 /* Handle a string concatenation operation. A temporary will be allocated to
3172 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3175 tree len
, type
, var
, tmp
, fndecl
;
3177 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3178 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3179 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3181 gfc_init_se (&lse
, se
);
3182 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3183 gfc_conv_string_parameter (&lse
);
3184 gfc_init_se (&rse
, se
);
3185 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3186 gfc_conv_string_parameter (&rse
);
3188 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3189 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3191 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3192 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3193 if (len
== NULL_TREE
)
3195 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3196 TREE_TYPE (lse
.string_length
),
3197 lse
.string_length
, rse
.string_length
);
3200 type
= build_pointer_type (type
);
3202 var
= gfc_conv_string_tmp (se
, type
, len
);
3204 /* Do the actual concatenation. */
3205 if (expr
->ts
.kind
== 1)
3206 fndecl
= gfor_fndecl_concat_string
;
3207 else if (expr
->ts
.kind
== 4)
3208 fndecl
= gfor_fndecl_concat_string_char4
;
3212 tmp
= build_call_expr_loc (input_location
,
3213 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3214 rse
.string_length
, rse
.expr
);
3215 gfc_add_expr_to_block (&se
->pre
, tmp
);
3217 /* Add the cleanup for the operands. */
3218 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3219 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3222 se
->string_length
= len
;
3225 /* Translates an op expression. Common (binary) cases are handled by this
3226 function, others are passed on. Recursion is used in either case.
3227 We use the fact that (op1.ts == op2.ts) (except for the power
3229 Operators need no special handling for scalarized expressions as long as
3230 they call gfc_conv_simple_val to get their operands.
3231 Character strings get special handling. */
3234 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3236 enum tree_code code
;
3245 switch (expr
->value
.op
.op
)
3247 case INTRINSIC_PARENTHESES
:
3248 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3249 && flag_protect_parens
)
3251 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3252 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3257 case INTRINSIC_UPLUS
:
3258 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3261 case INTRINSIC_UMINUS
:
3262 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3266 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3269 case INTRINSIC_PLUS
:
3273 case INTRINSIC_MINUS
:
3277 case INTRINSIC_TIMES
:
3281 case INTRINSIC_DIVIDE
:
3282 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3283 an integer, we must round towards zero, so we use a
3285 if (expr
->ts
.type
== BT_INTEGER
)
3286 code
= TRUNC_DIV_EXPR
;
3291 case INTRINSIC_POWER
:
3292 gfc_conv_power_op (se
, expr
);
3295 case INTRINSIC_CONCAT
:
3296 gfc_conv_concat_op (se
, expr
);
3300 code
= TRUTH_ANDIF_EXPR
;
3305 code
= TRUTH_ORIF_EXPR
;
3309 /* EQV and NEQV only work on logicals, but since we represent them
3310 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3312 case INTRINSIC_EQ_OS
:
3320 case INTRINSIC_NE_OS
:
3321 case INTRINSIC_NEQV
:
3328 case INTRINSIC_GT_OS
:
3335 case INTRINSIC_GE_OS
:
3342 case INTRINSIC_LT_OS
:
3349 case INTRINSIC_LE_OS
:
3355 case INTRINSIC_USER
:
3356 case INTRINSIC_ASSIGN
:
3357 /* These should be converted into function calls by the frontend. */
3361 fatal_error (input_location
, "Unknown intrinsic op");
3365 /* The only exception to this is **, which is handled separately anyway. */
3366 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3368 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3372 gfc_init_se (&lse
, se
);
3373 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3374 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3377 gfc_init_se (&rse
, se
);
3378 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3379 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3383 gfc_conv_string_parameter (&lse
);
3384 gfc_conv_string_parameter (&rse
);
3386 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3387 rse
.string_length
, rse
.expr
,
3388 expr
->value
.op
.op1
->ts
.kind
,
3390 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3391 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3394 type
= gfc_typenode_for_spec (&expr
->ts
);
3398 /* The result of logical ops is always logical_type_node. */
3399 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3400 lse
.expr
, rse
.expr
);
3401 se
->expr
= convert (type
, tmp
);
3404 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3406 /* Add the post blocks. */
3407 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3408 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3411 /* If a string's length is one, we convert it to a single character. */
3414 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3418 || !tree_fits_uhwi_p (len
)
3419 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3422 if (TREE_INT_CST_LOW (len
) == 1)
3424 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3425 return build_fold_indirect_ref_loc (input_location
, str
);
3429 && TREE_CODE (str
) == ADDR_EXPR
3430 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3431 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3432 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3433 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3434 && TREE_INT_CST_LOW (len
) > 1
3435 && TREE_INT_CST_LOW (len
)
3436 == (unsigned HOST_WIDE_INT
)
3437 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3439 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3440 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3441 if (TREE_CODE (ret
) == INTEGER_CST
)
3443 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3444 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3445 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3447 for (i
= 1; i
< length
; i
++)
3460 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3463 if (sym
->backend_decl
)
3465 /* This becomes the nominal_type in
3466 function.c:assign_parm_find_data_types. */
3467 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3468 /* This becomes the passed_type in
3469 function.c:assign_parm_find_data_types. C promotes char to
3470 integer for argument passing. */
3471 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3473 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3478 /* If we have a constant character expression, make it into an
3480 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3485 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3486 (int)(*expr
)->value
.character
.string
[0]);
3487 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3489 /* The expr needs to be compatible with a C int. If the
3490 conversion fails, then the 2 causes an ICE. */
3491 ts
.type
= BT_INTEGER
;
3492 ts
.kind
= gfc_c_int_kind
;
3493 gfc_convert_type (*expr
, &ts
, 2);
3496 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3498 if ((*expr
)->ref
== NULL
)
3500 se
->expr
= gfc_string_to_single_character
3501 (build_int_cst (integer_type_node
, 1),
3502 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3504 ((*expr
)->symtree
->n
.sym
)),
3509 gfc_conv_variable (se
, *expr
);
3510 se
->expr
= gfc_string_to_single_character
3511 (build_int_cst (integer_type_node
, 1),
3512 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3520 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3521 if STR is a string literal, otherwise return -1. */
3524 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3527 && TREE_CODE (str
) == ADDR_EXPR
3528 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3529 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3530 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3531 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3532 && tree_fits_uhwi_p (len
)
3533 && tree_to_uhwi (len
) >= 1
3534 && tree_to_uhwi (len
)
3535 == (unsigned HOST_WIDE_INT
)
3536 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3538 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3539 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3540 if (TREE_CODE (folded
) == INTEGER_CST
)
3542 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3543 int length
= TREE_STRING_LENGTH (string_cst
);
3544 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3546 for (; length
> 0; length
--)
3547 if (ptr
[length
- 1] != ' ')
3556 /* Helper to build a call to memcmp. */
3559 build_memcmp_call (tree s1
, tree s2
, tree n
)
3563 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3564 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3566 s1
= fold_convert (pvoid_type_node
, s1
);
3568 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3569 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3571 s2
= fold_convert (pvoid_type_node
, s2
);
3573 n
= fold_convert (size_type_node
, n
);
3575 tmp
= build_call_expr_loc (input_location
,
3576 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3579 return fold_convert (integer_type_node
, tmp
);
3582 /* Compare two strings. If they are all single characters, the result is the
3583 subtraction of them. Otherwise, we build a library call. */
3586 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3587 enum tree_code code
)
3593 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3594 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3596 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3597 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3599 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3601 /* Deal with single character specially. */
3602 sc1
= fold_convert (integer_type_node
, sc1
);
3603 sc2
= fold_convert (integer_type_node
, sc2
);
3604 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3608 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3610 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3612 /* If one string is a string literal with LEN_TRIM longer
3613 than the length of the second string, the strings
3615 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3616 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3617 return integer_one_node
;
3618 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3619 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3620 return integer_one_node
;
3623 /* We can compare via memcpy if the strings are known to be equal
3624 in length and they are
3626 - kind=4 and the comparison is for (in)equality. */
3628 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3629 && tree_int_cst_equal (len1
, len2
)
3630 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3635 chartype
= gfc_get_char_type (kind
);
3636 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3637 fold_convert (TREE_TYPE(len1
),
3638 TYPE_SIZE_UNIT(chartype
)),
3640 return build_memcmp_call (str1
, str2
, tmp
);
3643 /* Build a call for the comparison. */
3645 fndecl
= gfor_fndecl_compare_string
;
3647 fndecl
= gfor_fndecl_compare_string_char4
;
3651 return build_call_expr_loc (input_location
, fndecl
, 4,
3652 len1
, str1
, len2
, str2
);
3656 /* Return the backend_decl for a procedure pointer component. */
3659 get_proc_ptr_comp (gfc_expr
*e
)
3665 gfc_init_se (&comp_se
, NULL
);
3666 e2
= gfc_copy_expr (e
);
3667 /* We have to restore the expr type later so that gfc_free_expr frees
3668 the exact same thing that was allocated.
3669 TODO: This is ugly. */
3670 old_type
= e2
->expr_type
;
3671 e2
->expr_type
= EXPR_VARIABLE
;
3672 gfc_conv_expr (&comp_se
, e2
);
3673 e2
->expr_type
= old_type
;
3675 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3679 /* Convert a typebound function reference from a class object. */
3681 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3686 if (!VAR_P (base_object
))
3688 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3689 gfc_add_modify (&se
->pre
, var
, base_object
);
3691 se
->expr
= gfc_class_vptr_get (base_object
);
3692 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3694 while (ref
&& ref
->next
)
3696 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3697 if (ref
->u
.c
.sym
->attr
.extension
)
3698 conv_parent_component_references (se
, ref
);
3699 gfc_conv_component_ref (se
, ref
);
3700 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3705 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3709 if (gfc_is_proc_ptr_comp (expr
))
3710 tmp
= get_proc_ptr_comp (expr
);
3711 else if (sym
->attr
.dummy
)
3713 tmp
= gfc_get_symbol_decl (sym
);
3714 if (sym
->attr
.proc_pointer
)
3715 tmp
= build_fold_indirect_ref_loc (input_location
,
3717 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3718 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3722 if (!sym
->backend_decl
)
3723 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3725 TREE_USED (sym
->backend_decl
) = 1;
3727 tmp
= sym
->backend_decl
;
3729 if (sym
->attr
.cray_pointee
)
3731 /* TODO - make the cray pointee a pointer to a procedure,
3732 assign the pointer to it and use it for the call. This
3734 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3735 gfc_get_symbol_decl (sym
->cp_pointer
));
3736 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3739 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3741 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3742 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3749 /* Initialize MAPPING. */
3752 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3754 mapping
->syms
= NULL
;
3755 mapping
->charlens
= NULL
;
3759 /* Free all memory held by MAPPING (but not MAPPING itself). */
3762 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3764 gfc_interface_sym_mapping
*sym
;
3765 gfc_interface_sym_mapping
*nextsym
;
3767 gfc_charlen
*nextcl
;
3769 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3771 nextsym
= sym
->next
;
3772 sym
->new_sym
->n
.sym
->formal
= NULL
;
3773 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3774 gfc_free_expr (sym
->expr
);
3775 free (sym
->new_sym
);
3778 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3781 gfc_free_expr (cl
->length
);
3787 /* Return a copy of gfc_charlen CL. Add the returned structure to
3788 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3790 static gfc_charlen
*
3791 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3794 gfc_charlen
*new_charlen
;
3796 new_charlen
= gfc_get_charlen ();
3797 new_charlen
->next
= mapping
->charlens
;
3798 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3800 mapping
->charlens
= new_charlen
;
3805 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3806 array variable that can be used as the actual argument for dummy
3807 argument SYM. Add any initialization code to BLOCK. PACKED is as
3808 for gfc_get_nodesc_array_type and DATA points to the first element
3809 in the passed array. */
3812 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3813 gfc_packed packed
, tree data
)
3818 type
= gfc_typenode_for_spec (&sym
->ts
);
3819 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3820 !sym
->attr
.target
&& !sym
->attr
.pointer
3821 && !sym
->attr
.proc_pointer
);
3823 var
= gfc_create_var (type
, "ifm");
3824 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3830 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3831 and offset of descriptorless array type TYPE given that it has the same
3832 size as DESC. Add any set-up code to BLOCK. */
3835 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3842 offset
= gfc_index_zero_node
;
3843 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3845 dim
= gfc_rank_cst
[n
];
3846 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3847 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3849 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3850 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3851 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3852 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3854 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3856 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3857 gfc_array_index_type
,
3858 gfc_conv_descriptor_ubound_get (desc
, dim
),
3859 gfc_conv_descriptor_lbound_get (desc
, dim
));
3860 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3861 gfc_array_index_type
,
3862 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3863 tmp
= gfc_evaluate_now (tmp
, block
);
3864 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3866 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3867 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3868 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3869 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3870 gfc_array_index_type
, offset
, tmp
);
3872 offset
= gfc_evaluate_now (offset
, block
);
3873 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3877 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3878 in SE. The caller may still use se->expr and se->string_length after
3879 calling this function. */
3882 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3883 gfc_symbol
* sym
, gfc_se
* se
,
3886 gfc_interface_sym_mapping
*sm
;
3890 gfc_symbol
*new_sym
;
3892 gfc_symtree
*new_symtree
;
3894 /* Create a new symbol to represent the actual argument. */
3895 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3896 new_sym
->ts
= sym
->ts
;
3897 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3898 new_sym
->attr
.referenced
= 1;
3899 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3900 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3901 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3902 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3903 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3904 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3905 new_sym
->attr
.function
= sym
->attr
.function
;
3907 /* Ensure that the interface is available and that
3908 descriptors are passed for array actual arguments. */
3909 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3911 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3912 new_sym
->attr
.always_explicit
3913 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3916 /* Create a fake symtree for it. */
3918 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3919 new_symtree
->n
.sym
= new_sym
;
3920 gcc_assert (new_symtree
== root
);
3922 /* Create a dummy->actual mapping. */
3923 sm
= XCNEW (gfc_interface_sym_mapping
);
3924 sm
->next
= mapping
->syms
;
3926 sm
->new_sym
= new_symtree
;
3927 sm
->expr
= gfc_copy_expr (expr
);
3930 /* Stabilize the argument's value. */
3931 if (!sym
->attr
.function
&& se
)
3932 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3934 if (sym
->ts
.type
== BT_CHARACTER
)
3936 /* Create a copy of the dummy argument's length. */
3937 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3938 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3940 /* If the length is specified as "*", record the length that
3941 the caller is passing. We should use the callee's length
3942 in all other cases. */
3943 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3945 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3946 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3953 /* Use the passed value as-is if the argument is a function. */
3954 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3957 /* If the argument is a pass-by-value scalar, use the value as is. */
3958 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3961 /* If the argument is either a string or a pointer to a string,
3962 convert it to a boundless character type. */
3963 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3965 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3966 tmp
= build_pointer_type (tmp
);
3967 if (sym
->attr
.pointer
)
3968 value
= build_fold_indirect_ref_loc (input_location
,
3972 value
= fold_convert (tmp
, value
);
3975 /* If the argument is a scalar, a pointer to an array or an allocatable,
3977 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3978 value
= build_fold_indirect_ref_loc (input_location
,
3981 /* For character(*), use the actual argument's descriptor. */
3982 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3983 value
= build_fold_indirect_ref_loc (input_location
,
3986 /* If the argument is an array descriptor, use it to determine
3987 information about the actual argument's shape. */
3988 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3989 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3991 /* Get the actual argument's descriptor. */
3992 desc
= build_fold_indirect_ref_loc (input_location
,
3995 /* Create the replacement variable. */
3996 tmp
= gfc_conv_descriptor_data_get (desc
);
3997 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4000 /* Use DESC to work out the upper bounds, strides and offset. */
4001 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4004 /* Otherwise we have a packed array. */
4005 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4006 PACKED_FULL
, se
->expr
);
4008 new_sym
->backend_decl
= value
;
4012 /* Called once all dummy argument mappings have been added to MAPPING,
4013 but before the mapping is used to evaluate expressions. Pre-evaluate
4014 the length of each argument, adding any initialization code to PRE and
4015 any finalization code to POST. */
4018 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4019 stmtblock_t
* pre
, stmtblock_t
* post
)
4021 gfc_interface_sym_mapping
*sym
;
4025 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4026 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4027 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4029 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4030 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4031 gfc_init_se (&se
, NULL
);
4032 gfc_conv_expr (&se
, expr
);
4033 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4034 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4035 gfc_add_block_to_block (pre
, &se
.pre
);
4036 gfc_add_block_to_block (post
, &se
.post
);
4038 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4043 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4047 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4048 gfc_constructor_base base
)
4051 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4053 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4056 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4057 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4058 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4064 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4068 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4073 for (; ref
; ref
= ref
->next
)
4077 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4079 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4080 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4081 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4089 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4090 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4096 /* Convert intrinsic function calls into result expressions. */
4099 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4107 arg1
= expr
->value
.function
.actual
->expr
;
4108 if (expr
->value
.function
.actual
->next
)
4109 arg2
= expr
->value
.function
.actual
->next
->expr
;
4113 sym
= arg1
->symtree
->n
.sym
;
4115 if (sym
->attr
.dummy
)
4120 switch (expr
->value
.function
.isym
->id
)
4123 /* TODO figure out why this condition is necessary. */
4124 if (sym
->attr
.function
4125 && (arg1
->ts
.u
.cl
->length
== NULL
4126 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4127 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4130 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4133 case GFC_ISYM_LEN_TRIM
:
4134 new_expr
= gfc_copy_expr (arg1
);
4135 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4140 gfc_replace_expr (arg1
, new_expr
);
4144 if (!sym
->as
|| sym
->as
->rank
== 0)
4147 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4149 dup
= mpz_get_si (arg2
->value
.integer
);
4154 dup
= sym
->as
->rank
;
4158 for (; d
< dup
; d
++)
4162 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4164 gfc_free_expr (new_expr
);
4168 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4169 gfc_get_int_expr (gfc_default_integer_kind
,
4171 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4173 new_expr
= gfc_multiply (new_expr
, tmp
);
4179 case GFC_ISYM_LBOUND
:
4180 case GFC_ISYM_UBOUND
:
4181 /* TODO These implementations of lbound and ubound do not limit if
4182 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4184 if (!sym
->as
|| sym
->as
->rank
== 0)
4187 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4188 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4192 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4194 if (sym
->as
->lower
[d
])
4195 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4199 if (sym
->as
->upper
[d
])
4200 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4208 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4212 gfc_replace_expr (expr
, new_expr
);
4218 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4219 gfc_interface_mapping
* mapping
)
4221 gfc_formal_arglist
*f
;
4222 gfc_actual_arglist
*actual
;
4224 actual
= expr
->value
.function
.actual
;
4225 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4227 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4232 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4235 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4240 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4242 for (d
= 0; d
< as
->rank
; d
++)
4244 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4245 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4248 expr
->value
.function
.esym
->as
= as
;
4251 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4253 expr
->value
.function
.esym
->ts
.u
.cl
->length
4254 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4256 gfc_apply_interface_mapping_to_expr (mapping
,
4257 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4262 /* EXPR is a copy of an expression that appeared in the interface
4263 associated with MAPPING. Walk it recursively looking for references to
4264 dummy arguments that MAPPING maps to actual arguments. Replace each such
4265 reference with a reference to the associated actual argument. */
4268 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4271 gfc_interface_sym_mapping
*sym
;
4272 gfc_actual_arglist
*actual
;
4277 /* Copying an expression does not copy its length, so do that here. */
4278 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4280 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4281 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4284 /* Apply the mapping to any references. */
4285 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4287 /* ...and to the expression's symbol, if it has one. */
4288 /* TODO Find out why the condition on expr->symtree had to be moved into
4289 the loop rather than being outside it, as originally. */
4290 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4291 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4293 if (sym
->new_sym
->n
.sym
->backend_decl
)
4294 expr
->symtree
= sym
->new_sym
;
4296 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4299 /* ...and to subexpressions in expr->value. */
4300 switch (expr
->expr_type
)
4305 case EXPR_SUBSTRING
:
4309 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4310 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4314 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4315 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4317 if (expr
->value
.function
.esym
== NULL
4318 && expr
->value
.function
.isym
!= NULL
4319 && expr
->value
.function
.actual
->expr
->symtree
4320 && gfc_map_intrinsic_function (expr
, mapping
))
4323 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4324 if (sym
->old
== expr
->value
.function
.esym
)
4326 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4327 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4328 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4333 case EXPR_STRUCTURE
:
4334 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4347 /* Evaluate interface expression EXPR using MAPPING. Store the result
4351 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4352 gfc_se
* se
, gfc_expr
* expr
)
4354 expr
= gfc_copy_expr (expr
);
4355 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4356 gfc_conv_expr (se
, expr
);
4357 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4358 gfc_free_expr (expr
);
4362 /* Returns a reference to a temporary array into which a component of
4363 an actual argument derived type array is copied and then returned
4364 after the function call. */
4366 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4367 sym_intent intent
, bool formal_ptr
)
4375 gfc_array_info
*info
;
4385 gfc_init_se (&lse
, NULL
);
4386 gfc_init_se (&rse
, NULL
);
4388 /* Walk the argument expression. */
4389 rss
= gfc_walk_expr (expr
);
4391 gcc_assert (rss
!= gfc_ss_terminator
);
4393 /* Initialize the scalarizer. */
4394 gfc_init_loopinfo (&loop
);
4395 gfc_add_ss_to_loop (&loop
, rss
);
4397 /* Calculate the bounds of the scalarization. */
4398 gfc_conv_ss_startstride (&loop
);
4400 /* Build an ss for the temporary. */
4401 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4402 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4404 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4405 if (GFC_ARRAY_TYPE_P (base_type
)
4406 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4407 base_type
= gfc_get_element_type (base_type
);
4409 if (expr
->ts
.type
== BT_CLASS
)
4410 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4412 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4413 ? expr
->ts
.u
.cl
->backend_decl
4417 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4419 /* Associate the SS with the loop. */
4420 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4422 /* Setup the scalarizing loops. */
4423 gfc_conv_loop_setup (&loop
, &expr
->where
);
4425 /* Pass the temporary descriptor back to the caller. */
4426 info
= &loop
.temp_ss
->info
->data
.array
;
4427 parmse
->expr
= info
->descriptor
;
4429 /* Setup the gfc_se structures. */
4430 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4431 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4434 lse
.ss
= loop
.temp_ss
;
4435 gfc_mark_ss_chain_used (rss
, 1);
4436 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4438 /* Start the scalarized loop body. */
4439 gfc_start_scalarized_body (&loop
, &body
);
4441 /* Translate the expression. */
4442 gfc_conv_expr (&rse
, expr
);
4444 /* Reset the offset for the function call since the loop
4445 is zero based on the data pointer. Note that the temp
4446 comes first in the loop chain since it is added second. */
4447 if (gfc_is_class_array_function (expr
))
4449 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4450 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4451 gfc_index_zero_node
);
4454 gfc_conv_tmp_array_ref (&lse
);
4456 if (intent
!= INTENT_OUT
)
4458 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4459 gfc_add_expr_to_block (&body
, tmp
);
4460 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4461 gfc_trans_scalarizing_loops (&loop
, &body
);
4465 /* Make sure that the temporary declaration survives by merging
4466 all the loop declarations into the current context. */
4467 for (n
= 0; n
< loop
.dimen
; n
++)
4469 gfc_merge_block_scope (&body
);
4470 body
= loop
.code
[loop
.order
[n
]];
4472 gfc_merge_block_scope (&body
);
4475 /* Add the post block after the second loop, so that any
4476 freeing of allocated memory is done at the right time. */
4477 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4479 /**********Copy the temporary back again.*********/
4481 gfc_init_se (&lse
, NULL
);
4482 gfc_init_se (&rse
, NULL
);
4484 /* Walk the argument expression. */
4485 lss
= gfc_walk_expr (expr
);
4486 rse
.ss
= loop
.temp_ss
;
4489 /* Initialize the scalarizer. */
4490 gfc_init_loopinfo (&loop2
);
4491 gfc_add_ss_to_loop (&loop2
, lss
);
4493 dimen
= rse
.ss
->dimen
;
4495 /* Skip the write-out loop for this case. */
4496 if (gfc_is_class_array_function (expr
))
4497 goto class_array_fcn
;
4499 /* Calculate the bounds of the scalarization. */
4500 gfc_conv_ss_startstride (&loop2
);
4502 /* Setup the scalarizing loops. */
4503 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4505 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4506 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4508 gfc_mark_ss_chain_used (lss
, 1);
4509 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4511 /* Declare the variable to hold the temporary offset and start the
4512 scalarized loop body. */
4513 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4514 gfc_start_scalarized_body (&loop2
, &body
);
4516 /* Build the offsets for the temporary from the loop variables. The
4517 temporary array has lbounds of zero and strides of one in all
4518 dimensions, so this is very simple. The offset is only computed
4519 outside the innermost loop, so the overall transfer could be
4520 optimized further. */
4521 info
= &rse
.ss
->info
->data
.array
;
4523 tmp_index
= gfc_index_zero_node
;
4524 for (n
= dimen
- 1; n
> 0; n
--)
4527 tmp
= rse
.loop
->loopvar
[n
];
4528 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4529 tmp
, rse
.loop
->from
[n
]);
4530 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4533 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4534 gfc_array_index_type
,
4535 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4536 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4537 gfc_array_index_type
,
4538 tmp_str
, gfc_index_one_node
);
4540 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4541 gfc_array_index_type
, tmp
, tmp_str
);
4544 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4545 gfc_array_index_type
,
4546 tmp_index
, rse
.loop
->from
[0]);
4547 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4549 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4550 gfc_array_index_type
,
4551 rse
.loop
->loopvar
[0], offset
);
4553 /* Now use the offset for the reference. */
4554 tmp
= build_fold_indirect_ref_loc (input_location
,
4556 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4558 if (expr
->ts
.type
== BT_CHARACTER
)
4559 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4561 gfc_conv_expr (&lse
, expr
);
4563 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4565 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4566 gfc_add_expr_to_block (&body
, tmp
);
4568 /* Generate the copying loops. */
4569 gfc_trans_scalarizing_loops (&loop2
, &body
);
4571 /* Wrap the whole thing up by adding the second loop to the post-block
4572 and following it by the post-block of the first loop. In this way,
4573 if the temporary needs freeing, it is done after use! */
4574 if (intent
!= INTENT_IN
)
4576 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4577 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4582 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4584 gfc_cleanup_loop (&loop
);
4585 gfc_cleanup_loop (&loop2
);
4587 /* Pass the string length to the argument expression. */
4588 if (expr
->ts
.type
== BT_CHARACTER
)
4589 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4591 /* Determine the offset for pointer formal arguments and set the
4595 size
= gfc_index_one_node
;
4596 offset
= gfc_index_zero_node
;
4597 for (n
= 0; n
< dimen
; n
++)
4599 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4601 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4602 gfc_array_index_type
, tmp
,
4603 gfc_index_one_node
);
4604 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4608 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4611 gfc_index_one_node
);
4612 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4613 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4614 gfc_array_index_type
,
4616 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4618 gfc_array_index_type
,
4619 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4620 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4621 gfc_array_index_type
,
4622 tmp
, gfc_index_one_node
);
4623 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4624 gfc_array_index_type
, size
, tmp
);
4627 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4631 /* We want either the address for the data or the address of the descriptor,
4632 depending on the mode of passing array arguments. */
4634 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4636 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4642 /* Generate the code for argument list functions. */
4645 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4647 /* Pass by value for g77 %VAL(arg), pass the address
4648 indirectly for %LOC, else by reference. Thus %REF
4649 is a "do-nothing" and %LOC is the same as an F95
4651 if (strncmp (name
, "%VAL", 4) == 0)
4652 gfc_conv_expr (se
, expr
);
4653 else if (strncmp (name
, "%LOC", 4) == 0)
4655 gfc_conv_expr_reference (se
, expr
);
4656 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4658 else if (strncmp (name
, "%REF", 4) == 0)
4659 gfc_conv_expr_reference (se
, expr
);
4661 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4665 /* This function tells whether the middle-end representation of the expression
4666 E given as input may point to data otherwise accessible through a variable
4668 It is assumed that the only expressions that may alias are variables,
4669 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4671 This function is used to decide whether freeing an expression's allocatable
4672 components is safe or should be avoided.
4674 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4675 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4676 is necessary because for array constructors, aliasing depends on how
4678 - If E is an array constructor used as argument to an elemental procedure,
4679 the array, which is generated through shallow copy by the scalarizer,
4680 is used directly and can alias the expressions it was copied from.
4681 - If E is an array constructor used as argument to a non-elemental
4682 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4683 the array as in the previous case, but then that array is used
4684 to initialize a new descriptor through deep copy. There is no alias
4685 possible in that case.
4686 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4690 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4694 if (e
->expr_type
== EXPR_VARIABLE
)
4696 else if (e
->expr_type
== EXPR_FUNCTION
)
4698 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4700 if (proc_ifc
->result
!= NULL
4701 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4702 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4703 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4704 || proc_ifc
->result
->attr
.pointer
))
4709 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4712 for (c
= gfc_constructor_first (e
->value
.constructor
);
4713 c
; c
= gfc_constructor_next (c
))
4715 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4722 /* Generate code for a procedure call. Note can return se->post != NULL.
4723 If se->direct_byref is set then se->expr contains the return parameter.
4724 Return nonzero, if the call has alternate specifiers.
4725 'expr' is only needed for procedure pointer components. */
4728 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4729 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4730 vec
<tree
, va_gc
> *append_args
)
4732 gfc_interface_mapping mapping
;
4733 vec
<tree
, va_gc
> *arglist
;
4734 vec
<tree
, va_gc
> *retargs
;
4738 gfc_array_info
*info
;
4745 vec
<tree
, va_gc
> *stringargs
;
4746 vec
<tree
, va_gc
> *optionalargs
;
4748 gfc_formal_arglist
*formal
;
4749 gfc_actual_arglist
*arg
;
4750 int has_alternate_specifier
= 0;
4751 bool need_interface_mapping
;
4759 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4760 gfc_component
*comp
= NULL
;
4767 optionalargs
= NULL
;
4772 comp
= gfc_get_proc_ptr_comp (expr
);
4774 bool elemental_proc
= (comp
4775 && comp
->ts
.interface
4776 && comp
->ts
.interface
->attr
.elemental
)
4777 || (comp
&& comp
->attr
.elemental
)
4778 || sym
->attr
.elemental
;
4782 if (!elemental_proc
)
4784 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4785 if (se
->ss
->info
->useflags
)
4787 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4788 && sym
->result
->attr
.dimension
)
4789 || (comp
&& comp
->attr
.dimension
)
4790 || gfc_is_class_array_function (expr
));
4791 gcc_assert (se
->loop
!= NULL
);
4792 /* Access the previously obtained result. */
4793 gfc_conv_tmp_array_ref (se
);
4797 info
= &se
->ss
->info
->data
.array
;
4802 gfc_init_block (&post
);
4803 gfc_init_interface_mapping (&mapping
);
4806 formal
= gfc_sym_get_dummy_args (sym
);
4807 need_interface_mapping
= sym
->attr
.dimension
||
4808 (sym
->ts
.type
== BT_CHARACTER
4809 && sym
->ts
.u
.cl
->length
4810 && sym
->ts
.u
.cl
->length
->expr_type
4815 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4816 need_interface_mapping
= comp
->attr
.dimension
||
4817 (comp
->ts
.type
== BT_CHARACTER
4818 && comp
->ts
.u
.cl
->length
4819 && comp
->ts
.u
.cl
->length
->expr_type
4823 base_object
= NULL_TREE
;
4824 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4825 is the third and fourth argument to such a function call a value
4826 denoting the number of elements to copy (i.e., most of the time the
4827 length of a deferred length string). */
4828 ulim_copy
= (formal
== NULL
)
4829 && UNLIMITED_POLY (sym
)
4830 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4832 /* Evaluate the arguments. */
4833 for (arg
= args
, argc
= 0; arg
!= NULL
;
4834 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4837 fsym
= formal
? formal
->sym
: NULL
;
4838 parm_kind
= MISSING
;
4840 /* If the procedure requires an explicit interface, the actual
4841 argument is passed according to the corresponding formal
4842 argument. If the corresponding formal argument is a POINTER,
4843 ALLOCATABLE or assumed shape, we do not use g77's calling
4844 convention, and pass the address of the array descriptor
4845 instead. Otherwise we use g77's calling convention, in other words
4846 pass the array data pointer without descriptor. */
4847 bool nodesc_arg
= fsym
!= NULL
4848 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4850 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4851 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4853 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4855 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4857 /* Class array expressions are sometimes coming completely unadorned
4858 with either arrayspec or _data component. Correct that here.
4859 OOP-TODO: Move this to the frontend. */
4860 if (e
&& e
->expr_type
== EXPR_VARIABLE
4862 && e
->ts
.type
== BT_CLASS
4863 && (CLASS_DATA (e
)->attr
.codimension
4864 || CLASS_DATA (e
)->attr
.dimension
))
4866 gfc_typespec temp_ts
= e
->ts
;
4867 gfc_add_class_array_ref (e
);
4873 if (se
->ignore_optional
)
4875 /* Some intrinsics have already been resolved to the correct
4879 else if (arg
->label
)
4881 has_alternate_specifier
= 1;
4886 gfc_init_se (&parmse
, NULL
);
4888 /* For scalar arguments with VALUE attribute which are passed by
4889 value, pass "0" and a hidden argument gives the optional
4891 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4892 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4893 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4895 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4897 vec_safe_push (optionalargs
, boolean_false_node
);
4901 /* Pass a NULL pointer for an absent arg. */
4902 parmse
.expr
= null_pointer_node
;
4903 if (arg
->missing_arg_type
== BT_CHARACTER
)
4904 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4909 else if (arg
->expr
->expr_type
== EXPR_NULL
4910 && fsym
&& !fsym
->attr
.pointer
4911 && (fsym
->ts
.type
!= BT_CLASS
4912 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4914 /* Pass a NULL pointer to denote an absent arg. */
4915 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4916 && (fsym
->ts
.type
!= BT_CLASS
4917 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4918 gfc_init_se (&parmse
, NULL
);
4919 parmse
.expr
= null_pointer_node
;
4920 if (arg
->missing_arg_type
== BT_CHARACTER
)
4921 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4923 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4924 && e
->ts
.type
== BT_DERIVED
)
4926 /* The derived type needs to be converted to a temporary
4928 gfc_init_se (&parmse
, se
);
4929 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4931 && e
->expr_type
== EXPR_VARIABLE
4932 && e
->symtree
->n
.sym
->attr
.optional
,
4933 CLASS_DATA (fsym
)->attr
.class_pointer
4934 || CLASS_DATA (fsym
)->attr
.allocatable
);
4936 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4938 /* The intrinsic type needs to be converted to a temporary
4939 CLASS object for the unlimited polymorphic formal. */
4940 gfc_init_se (&parmse
, se
);
4941 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4943 else if (se
->ss
&& se
->ss
->info
->useflags
)
4949 /* An elemental function inside a scalarized loop. */
4950 gfc_init_se (&parmse
, se
);
4951 parm_kind
= ELEMENTAL
;
4953 /* When no fsym is present, ulim_copy is set and this is a third or
4954 fourth argument, use call-by-value instead of by reference to
4955 hand the length properties to the copy routine (i.e., most of the
4956 time this will be a call to a __copy_character_* routine where the
4957 third and fourth arguments are the lengths of a deferred length
4959 if ((fsym
&& fsym
->attr
.value
)
4960 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4961 gfc_conv_expr (&parmse
, e
);
4963 gfc_conv_expr_reference (&parmse
, e
);
4965 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4966 && e
->expr_type
== EXPR_FUNCTION
)
4967 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4970 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4971 && gfc_is_class_container_ref (e
))
4973 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4975 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4976 && e
->symtree
->n
.sym
->attr
.optional
)
4978 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4979 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4980 TREE_TYPE (parmse
.expr
),
4982 fold_convert (TREE_TYPE (parmse
.expr
),
4983 null_pointer_node
));
4987 /* If we are passing an absent array as optional dummy to an
4988 elemental procedure, make sure that we pass NULL when the data
4989 pointer is NULL. We need this extra conditional because of
4990 scalarization which passes arrays elements to the procedure,
4991 ignoring the fact that the array can be absent/unallocated/... */
4992 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4994 tree descriptor_data
;
4996 descriptor_data
= ss
->info
->data
.array
.data
;
4997 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4999 fold_convert (TREE_TYPE (descriptor_data
),
5000 null_pointer_node
));
5002 = fold_build3_loc (input_location
, COND_EXPR
,
5003 TREE_TYPE (parmse
.expr
),
5004 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5005 fold_convert (TREE_TYPE (parmse
.expr
),
5010 /* The scalarizer does not repackage the reference to a class
5011 array - instead it returns a pointer to the data element. */
5012 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5013 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5014 fsym
->attr
.intent
!= INTENT_IN
5015 && (CLASS_DATA (fsym
)->attr
.class_pointer
5016 || CLASS_DATA (fsym
)->attr
.allocatable
),
5018 && e
->expr_type
== EXPR_VARIABLE
5019 && e
->symtree
->n
.sym
->attr
.optional
,
5020 CLASS_DATA (fsym
)->attr
.class_pointer
5021 || CLASS_DATA (fsym
)->attr
.allocatable
);
5028 gfc_init_se (&parmse
, NULL
);
5030 /* Check whether the expression is a scalar or not; we cannot use
5031 e->rank as it can be nonzero for functions arguments. */
5032 argss
= gfc_walk_expr (e
);
5033 scalar
= argss
== gfc_ss_terminator
;
5035 gfc_free_ss_chain (argss
);
5037 /* Special handling for passing scalar polymorphic coarrays;
5038 otherwise one passes "class->_data.data" instead of "&class". */
5039 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5040 && fsym
&& fsym
->ts
.type
== BT_CLASS
5041 && CLASS_DATA (fsym
)->attr
.codimension
5042 && !CLASS_DATA (fsym
)->attr
.dimension
)
5044 gfc_add_class_array_ref (e
);
5045 parmse
.want_coarray
= 1;
5049 /* A scalar or transformational function. */
5052 if (e
->expr_type
== EXPR_VARIABLE
5053 && e
->symtree
->n
.sym
->attr
.cray_pointee
5054 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5056 /* The Cray pointer needs to be converted to a pointer to
5057 a type given by the expression. */
5058 gfc_conv_expr (&parmse
, e
);
5059 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5060 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5061 parmse
.expr
= convert (type
, tmp
);
5063 else if (fsym
&& fsym
->attr
.value
)
5065 if (fsym
->ts
.type
== BT_CHARACTER
5066 && fsym
->ts
.is_c_interop
5067 && fsym
->ns
->proc_name
!= NULL
5068 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5071 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5072 if (parmse
.expr
== NULL
)
5073 gfc_conv_expr (&parmse
, e
);
5077 gfc_conv_expr (&parmse
, e
);
5078 if (fsym
->attr
.optional
5079 && fsym
->ts
.type
!= BT_CLASS
5080 && fsym
->ts
.type
!= BT_DERIVED
)
5082 if (e
->expr_type
!= EXPR_VARIABLE
5083 || !e
->symtree
->n
.sym
->attr
.optional
5085 vec_safe_push (optionalargs
, boolean_true_node
);
5088 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5089 if (!e
->symtree
->n
.sym
->attr
.value
)
5091 = fold_build3_loc (input_location
, COND_EXPR
,
5092 TREE_TYPE (parmse
.expr
),
5094 fold_convert (TREE_TYPE (parmse
.expr
),
5095 integer_zero_node
));
5097 vec_safe_push (optionalargs
, tmp
);
5102 else if (arg
->name
&& arg
->name
[0] == '%')
5103 /* Argument list functions %VAL, %LOC and %REF are signalled
5104 through arg->name. */
5105 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5106 else if ((e
->expr_type
== EXPR_FUNCTION
)
5107 && ((e
->value
.function
.esym
5108 && e
->value
.function
.esym
->result
->attr
.pointer
)
5109 || (!e
->value
.function
.esym
5110 && e
->symtree
->n
.sym
->attr
.pointer
))
5111 && fsym
&& fsym
->attr
.target
)
5113 gfc_conv_expr (&parmse
, e
);
5114 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5116 else if (e
->expr_type
== EXPR_FUNCTION
5117 && e
->symtree
->n
.sym
->result
5118 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5119 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5121 /* Functions returning procedure pointers. */
5122 gfc_conv_expr (&parmse
, e
);
5123 if (fsym
&& fsym
->attr
.proc_pointer
)
5124 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5128 if (e
->ts
.type
== BT_CLASS
&& fsym
5129 && fsym
->ts
.type
== BT_CLASS
5130 && (!CLASS_DATA (fsym
)->as
5131 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5132 && CLASS_DATA (e
)->attr
.codimension
)
5134 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5135 gcc_assert (!CLASS_DATA (fsym
)->as
);
5136 gfc_add_class_array_ref (e
);
5137 parmse
.want_coarray
= 1;
5138 gfc_conv_expr_reference (&parmse
, e
);
5139 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5141 && e
->expr_type
== EXPR_VARIABLE
);
5143 else if (e
->ts
.type
== BT_CLASS
&& fsym
5144 && fsym
->ts
.type
== BT_CLASS
5145 && !CLASS_DATA (fsym
)->as
5146 && !CLASS_DATA (e
)->as
5147 && strcmp (fsym
->ts
.u
.derived
->name
,
5148 e
->ts
.u
.derived
->name
))
5150 type
= gfc_typenode_for_spec (&fsym
->ts
);
5151 var
= gfc_create_var (type
, fsym
->name
);
5152 gfc_conv_expr (&parmse
, e
);
5153 if (fsym
->attr
.optional
5154 && e
->expr_type
== EXPR_VARIABLE
5155 && e
->symtree
->n
.sym
->attr
.optional
)
5159 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5160 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5161 logical_type_node
, tmp
,
5162 fold_convert (TREE_TYPE (tmp
),
5163 null_pointer_node
));
5164 gfc_start_block (&block
);
5165 gfc_add_modify (&block
, var
,
5166 fold_build1_loc (input_location
,
5168 type
, parmse
.expr
));
5169 gfc_add_expr_to_block (&parmse
.pre
,
5170 fold_build3_loc (input_location
,
5171 COND_EXPR
, void_type_node
,
5172 cond
, gfc_finish_block (&block
),
5173 build_empty_stmt (input_location
)));
5174 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5175 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5176 TREE_TYPE (parmse
.expr
),
5178 fold_convert (TREE_TYPE (parmse
.expr
),
5179 null_pointer_node
));
5183 /* Since the internal representation of unlimited
5184 polymorphic expressions includes an extra field
5185 that other class objects do not, a cast to the
5186 formal type does not work. */
5187 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5191 /* Set the _data field. */
5192 tmp
= gfc_class_data_get (var
);
5193 efield
= fold_convert (TREE_TYPE (tmp
),
5194 gfc_class_data_get (parmse
.expr
));
5195 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5197 /* Set the _vptr field. */
5198 tmp
= gfc_class_vptr_get (var
);
5199 efield
= fold_convert (TREE_TYPE (tmp
),
5200 gfc_class_vptr_get (parmse
.expr
));
5201 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5203 /* Set the _len field. */
5204 tmp
= gfc_class_len_get (var
);
5205 gfc_add_modify (&parmse
.pre
, tmp
,
5206 build_int_cst (TREE_TYPE (tmp
), 0));
5210 tmp
= fold_build1_loc (input_location
,
5213 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5216 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5220 gfc_conv_expr_reference (&parmse
, e
);
5222 /* Catch base objects that are not variables. */
5223 if (e
->ts
.type
== BT_CLASS
5224 && e
->expr_type
!= EXPR_VARIABLE
5225 && expr
&& e
== expr
->base_expr
)
5226 base_object
= build_fold_indirect_ref_loc (input_location
,
5229 /* A class array element needs converting back to be a
5230 class object, if the formal argument is a class object. */
5231 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5232 && e
->ts
.type
== BT_CLASS
5233 && ((CLASS_DATA (fsym
)->as
5234 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5235 || CLASS_DATA (e
)->attr
.dimension
))
5236 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5237 fsym
->attr
.intent
!= INTENT_IN
5238 && (CLASS_DATA (fsym
)->attr
.class_pointer
5239 || CLASS_DATA (fsym
)->attr
.allocatable
),
5241 && e
->expr_type
== EXPR_VARIABLE
5242 && e
->symtree
->n
.sym
->attr
.optional
,
5243 CLASS_DATA (fsym
)->attr
.class_pointer
5244 || CLASS_DATA (fsym
)->attr
.allocatable
);
5246 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5247 allocated on entry, it must be deallocated. */
5248 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5249 && (fsym
->attr
.allocatable
5250 || (fsym
->ts
.type
== BT_CLASS
5251 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5256 gfc_init_block (&block
);
5258 if (e
->ts
.type
== BT_CLASS
)
5259 ptr
= gfc_class_data_get (ptr
);
5261 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5264 gfc_add_expr_to_block (&block
, tmp
);
5265 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5266 void_type_node
, ptr
,
5268 gfc_add_expr_to_block (&block
, tmp
);
5270 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5272 gfc_add_modify (&block
, ptr
,
5273 fold_convert (TREE_TYPE (ptr
),
5274 null_pointer_node
));
5275 gfc_add_expr_to_block (&block
, tmp
);
5277 else if (fsym
->ts
.type
== BT_CLASS
)
5280 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5281 tmp
= gfc_get_symbol_decl (vtab
);
5282 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5283 ptr
= gfc_class_vptr_get (parmse
.expr
);
5284 gfc_add_modify (&block
, ptr
,
5285 fold_convert (TREE_TYPE (ptr
), tmp
));
5286 gfc_add_expr_to_block (&block
, tmp
);
5289 if (fsym
->attr
.optional
5290 && e
->expr_type
== EXPR_VARIABLE
5291 && e
->symtree
->n
.sym
->attr
.optional
)
5293 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5295 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5296 gfc_finish_block (&block
),
5297 build_empty_stmt (input_location
));
5300 tmp
= gfc_finish_block (&block
);
5302 gfc_add_expr_to_block (&se
->pre
, tmp
);
5305 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5306 || fsym
->ts
.type
== BT_ASSUMED
)
5307 && e
->ts
.type
== BT_CLASS
5308 && !CLASS_DATA (e
)->attr
.dimension
5309 && !CLASS_DATA (e
)->attr
.codimension
)
5310 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5312 /* Wrap scalar variable in a descriptor. We need to convert
5313 the address of a pointer back to the pointer itself before,
5314 we can assign it to the data field. */
5316 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5317 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5320 if (TREE_CODE (tmp
) == ADDR_EXPR
5321 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5322 tmp
= TREE_OPERAND (tmp
, 0);
5323 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5325 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5328 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5329 && ((fsym
->attr
.pointer
5330 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5331 || (fsym
->attr
.proc_pointer
5332 && !(e
->expr_type
== EXPR_VARIABLE
5333 && e
->symtree
->n
.sym
->attr
.dummy
))
5334 || (fsym
->attr
.proc_pointer
5335 && e
->expr_type
== EXPR_VARIABLE
5336 && gfc_is_proc_ptr_comp (e
))
5337 || (fsym
->attr
.allocatable
5338 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5340 /* Scalar pointer dummy args require an extra level of
5341 indirection. The null pointer already contains
5342 this level of indirection. */
5343 parm_kind
= SCALAR_POINTER
;
5344 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5348 else if (e
->ts
.type
== BT_CLASS
5349 && fsym
&& fsym
->ts
.type
== BT_CLASS
5350 && (CLASS_DATA (fsym
)->attr
.dimension
5351 || CLASS_DATA (fsym
)->attr
.codimension
))
5353 /* Pass a class array. */
5354 parmse
.use_offset
= 1;
5355 gfc_conv_expr_descriptor (&parmse
, e
);
5357 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5358 allocated on entry, it must be deallocated. */
5359 if (fsym
->attr
.intent
== INTENT_OUT
5360 && CLASS_DATA (fsym
)->attr
.allocatable
)
5365 gfc_init_block (&block
);
5367 ptr
= gfc_class_data_get (ptr
);
5369 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5370 NULL_TREE
, NULL_TREE
,
5372 GFC_CAF_COARRAY_NOCOARRAY
);
5373 gfc_add_expr_to_block (&block
, tmp
);
5374 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5375 void_type_node
, ptr
,
5377 gfc_add_expr_to_block (&block
, tmp
);
5378 gfc_reset_vptr (&block
, e
);
5380 if (fsym
->attr
.optional
5381 && e
->expr_type
== EXPR_VARIABLE
5383 || (e
->ref
->type
== REF_ARRAY
5384 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5385 && e
->symtree
->n
.sym
->attr
.optional
)
5387 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5389 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5390 gfc_finish_block (&block
),
5391 build_empty_stmt (input_location
));
5394 tmp
= gfc_finish_block (&block
);
5396 gfc_add_expr_to_block (&se
->pre
, tmp
);
5399 /* The conversion does not repackage the reference to a class
5400 array - _data descriptor. */
5401 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5402 fsym
->attr
.intent
!= INTENT_IN
5403 && (CLASS_DATA (fsym
)->attr
.class_pointer
5404 || CLASS_DATA (fsym
)->attr
.allocatable
),
5406 && e
->expr_type
== EXPR_VARIABLE
5407 && e
->symtree
->n
.sym
->attr
.optional
,
5408 CLASS_DATA (fsym
)->attr
.class_pointer
5409 || CLASS_DATA (fsym
)->attr
.allocatable
);
5413 /* If the argument is a function call that may not create
5414 a temporary for the result, we have to check that we
5415 can do it, i.e. that there is no alias between this
5416 argument and another one. */
5417 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5423 intent
= fsym
->attr
.intent
;
5425 intent
= INTENT_UNKNOWN
;
5427 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5429 parmse
.force_tmp
= 1;
5431 iarg
= e
->value
.function
.actual
->expr
;
5433 /* Temporary needed if aliasing due to host association. */
5434 if (sym
->attr
.contained
5436 && !sym
->attr
.implicit_pure
5437 && !sym
->attr
.use_assoc
5438 && iarg
->expr_type
== EXPR_VARIABLE
5439 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5440 parmse
.force_tmp
= 1;
5442 /* Ditto within module. */
5443 if (sym
->attr
.use_assoc
5445 && !sym
->attr
.implicit_pure
5446 && iarg
->expr_type
== EXPR_VARIABLE
5447 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5448 parmse
.force_tmp
= 1;
5451 if (e
->expr_type
== EXPR_VARIABLE
5452 && is_subref_array (e
)
5453 && !(fsym
&& fsym
->attr
.pointer
))
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 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5459 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5460 fsym
&& fsym
->attr
.pointer
);
5461 else if (gfc_is_class_array_ref (e
, NULL
)
5462 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5463 /* The actual argument is a component reference to an
5464 array of derived types. In this case, the argument
5465 is converted to a temporary, which is passed and then
5466 written back after the procedure call.
5467 OOP-TODO: Insert code so that if the dynamic type is
5468 the same as the declared type, copy-in/copy-out does
5470 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5471 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5472 fsym
&& fsym
->attr
.pointer
);
5474 else if (gfc_is_class_array_function (e
)
5475 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5476 /* See previous comment. For function actual argument,
5477 the write out is not needed so the intent is set as
5480 e
->must_finalize
= 1;
5481 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5483 fsym
&& fsym
->attr
.pointer
);
5486 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5489 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5490 allocated on entry, it must be deallocated. */
5491 if (fsym
&& fsym
->attr
.allocatable
5492 && fsym
->attr
.intent
== INTENT_OUT
)
5494 if (fsym
->ts
.type
== BT_DERIVED
5495 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5497 // deallocate the components first
5498 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5499 parmse
.expr
, e
->rank
);
5500 if (tmp
!= NULL_TREE
)
5501 gfc_add_expr_to_block (&se
->pre
, tmp
);
5504 tmp
= build_fold_indirect_ref_loc (input_location
,
5506 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5507 tmp
= gfc_conv_descriptor_data_get (tmp
);
5508 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5509 NULL_TREE
, NULL_TREE
, true,
5511 GFC_CAF_COARRAY_NOCOARRAY
);
5512 if (fsym
->attr
.optional
5513 && e
->expr_type
== EXPR_VARIABLE
5514 && e
->symtree
->n
.sym
->attr
.optional
)
5515 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5517 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5518 tmp
, build_empty_stmt (input_location
));
5519 gfc_add_expr_to_block (&se
->pre
, tmp
);
5524 /* The case with fsym->attr.optional is that of a user subroutine
5525 with an interface indicating an optional argument. When we call
5526 an intrinsic subroutine, however, fsym is NULL, but we might still
5527 have an optional argument, so we proceed to the substitution
5529 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5531 /* If an optional argument is itself an optional dummy argument,
5532 check its presence and substitute a null if absent. This is
5533 only needed when passing an array to an elemental procedure
5534 as then array elements are accessed - or no NULL pointer is
5535 allowed and a "1" or "0" should be passed if not present.
5536 When passing a non-array-descriptor full array to a
5537 non-array-descriptor dummy, no check is needed. For
5538 array-descriptor actual to array-descriptor dummy, see
5539 PR 41911 for why a check has to be inserted.
5540 fsym == NULL is checked as intrinsics required the descriptor
5541 but do not always set fsym. */
5542 if (e
->expr_type
== EXPR_VARIABLE
5543 && e
->symtree
->n
.sym
->attr
.optional
5544 && ((e
->rank
!= 0 && elemental_proc
)
5545 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5549 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5550 || fsym
->as
->type
== AS_ASSUMED_RANK
5551 || fsym
->as
->type
== AS_DEFERRED
))))))
5552 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5553 e
->representation
.length
);
5558 /* Obtain the character length of an assumed character length
5559 length procedure from the typespec. */
5560 if (fsym
->ts
.type
== BT_CHARACTER
5561 && parmse
.string_length
== NULL_TREE
5562 && e
->ts
.type
== BT_PROCEDURE
5563 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5564 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5565 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5567 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5568 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5572 if (fsym
&& need_interface_mapping
&& e
)
5573 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5575 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5576 gfc_add_block_to_block (&post
, &parmse
.post
);
5578 /* Allocated allocatable components of derived types must be
5579 deallocated for non-variable scalars, array arguments to elemental
5580 procedures, and array arguments with descriptor to non-elemental
5581 procedures. As bounds information for descriptorless arrays is no
5582 longer available here, they are dealt with in trans-array.c
5583 (gfc_conv_array_parameter). */
5584 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5585 && e
->ts
.u
.derived
->attr
.alloc_comp
5586 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5587 && !expr_may_alias_variables (e
, elemental_proc
))
5590 /* It is known the e returns a structure type with at least one
5591 allocatable component. When e is a function, ensure that the
5592 function is called once only by using a temporary variable. */
5593 if (!DECL_P (parmse
.expr
))
5594 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5595 parmse
.expr
, &se
->pre
);
5597 if (fsym
&& fsym
->attr
.value
)
5600 tmp
= build_fold_indirect_ref_loc (input_location
,
5603 parm_rank
= e
->rank
;
5611 case (SCALAR_POINTER
):
5612 tmp
= build_fold_indirect_ref_loc (input_location
,
5617 if (e
->expr_type
== EXPR_OP
5618 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5619 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5622 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5623 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5625 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5628 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5630 /* The derived type is passed to gfc_deallocate_alloc_comp.
5631 Therefore, class actuals can handled correctly but derived
5632 types passed to class formals need the _data component. */
5633 tmp
= gfc_class_data_get (tmp
);
5634 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5635 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5638 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5640 gfc_prepend_expr_to_block (&post
, tmp
);
5643 /* Add argument checking of passing an unallocated/NULL actual to
5644 a nonallocatable/nonpointer dummy. */
5646 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5648 symbol_attribute attr
;
5652 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5653 attr
= gfc_expr_attr (e
);
5655 goto end_pointer_check
;
5657 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5658 allocatable to an optional dummy, cf. 12.5.2.12. */
5659 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5660 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5661 goto end_pointer_check
;
5665 /* If the actual argument is an optional pointer/allocatable and
5666 the formal argument takes an nonpointer optional value,
5667 it is invalid to pass a non-present argument on, even
5668 though there is no technical reason for this in gfortran.
5669 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5670 tree present
, null_ptr
, type
;
5672 if (attr
.allocatable
5673 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5674 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5675 "allocated or not present",
5676 e
->symtree
->n
.sym
->name
);
5677 else if (attr
.pointer
5678 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5679 msg
= xasprintf ("Pointer actual argument '%s' is not "
5680 "associated or not present",
5681 e
->symtree
->n
.sym
->name
);
5682 else if (attr
.proc_pointer
5683 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5684 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5685 "associated or not present",
5686 e
->symtree
->n
.sym
->name
);
5688 goto end_pointer_check
;
5690 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5691 type
= TREE_TYPE (present
);
5692 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5693 logical_type_node
, present
,
5695 null_pointer_node
));
5696 type
= TREE_TYPE (parmse
.expr
);
5697 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5698 logical_type_node
, parmse
.expr
,
5700 null_pointer_node
));
5701 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5702 logical_type_node
, present
, null_ptr
);
5706 if (attr
.allocatable
5707 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5708 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5709 "allocated", e
->symtree
->n
.sym
->name
);
5710 else if (attr
.pointer
5711 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5712 msg
= xasprintf ("Pointer actual argument '%s' is not "
5713 "associated", e
->symtree
->n
.sym
->name
);
5714 else if (attr
.proc_pointer
5715 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5716 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5717 "associated", e
->symtree
->n
.sym
->name
);
5719 goto end_pointer_check
;
5723 /* If the argument is passed by value, we need to strip the
5725 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5726 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5728 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5729 logical_type_node
, tmp
,
5730 fold_convert (TREE_TYPE (tmp
),
5731 null_pointer_node
));
5734 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5740 /* Deferred length dummies pass the character length by reference
5741 so that the value can be returned. */
5742 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5744 if (INDIRECT_REF_P (parmse
.string_length
))
5745 /* In chains of functions/procedure calls the string_length already
5746 is a pointer to the variable holding the length. Therefore
5747 remove the deref on call. */
5748 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5751 tmp
= parmse
.string_length
;
5752 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5753 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5754 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5758 /* Character strings are passed as two parameters, a length and a
5759 pointer - except for Bind(c) which only passes the pointer.
5760 An unlimited polymorphic formal argument likewise does not
5762 if (parmse
.string_length
!= NULL_TREE
5763 && !sym
->attr
.is_bind_c
5764 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5765 vec_safe_push (stringargs
, parmse
.string_length
);
5767 /* When calling __copy for character expressions to unlimited
5768 polymorphic entities, the dst argument needs a string length. */
5769 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5770 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5771 && arg
->next
&& arg
->next
->expr
5772 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5773 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5774 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5775 vec_safe_push (stringargs
, parmse
.string_length
);
5777 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5778 pass the token and the offset as additional arguments. */
5779 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5780 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5781 && !fsym
->attr
.allocatable
)
5782 || (fsym
->ts
.type
== BT_CLASS
5783 && CLASS_DATA (fsym
)->attr
.codimension
5784 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5786 /* Token and offset. */
5787 vec_safe_push (stringargs
, null_pointer_node
);
5788 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5789 gcc_assert (fsym
->attr
.optional
);
5791 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5792 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5793 && !fsym
->attr
.allocatable
)
5794 || (fsym
->ts
.type
== BT_CLASS
5795 && CLASS_DATA (fsym
)->attr
.codimension
5796 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5798 tree caf_decl
, caf_type
;
5801 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5802 caf_type
= TREE_TYPE (caf_decl
);
5804 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5805 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5806 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5807 tmp
= gfc_conv_descriptor_token (caf_decl
);
5808 else if (DECL_LANG_SPECIFIC (caf_decl
)
5809 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5810 tmp
= GFC_DECL_TOKEN (caf_decl
);
5813 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5814 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5815 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5818 vec_safe_push (stringargs
, tmp
);
5820 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5821 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5822 offset
= build_int_cst (gfc_array_index_type
, 0);
5823 else if (DECL_LANG_SPECIFIC (caf_decl
)
5824 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5825 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5826 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5827 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5829 offset
= build_int_cst (gfc_array_index_type
, 0);
5831 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5832 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5835 gcc_assert (POINTER_TYPE_P (caf_type
));
5839 tmp2
= fsym
->ts
.type
== BT_CLASS
5840 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5841 if ((fsym
->ts
.type
!= BT_CLASS
5842 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5843 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5844 || (fsym
->ts
.type
== BT_CLASS
5845 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5846 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5848 if (fsym
->ts
.type
== BT_CLASS
)
5849 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5852 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5853 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5855 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5856 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5858 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5859 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5862 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5865 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5866 gfc_array_index_type
,
5867 fold_convert (gfc_array_index_type
, tmp2
),
5868 fold_convert (gfc_array_index_type
, tmp
));
5869 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5870 gfc_array_index_type
, offset
, tmp
);
5872 vec_safe_push (stringargs
, offset
);
5875 vec_safe_push (arglist
, parmse
.expr
);
5877 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5881 else if (sym
->ts
.type
== BT_CLASS
)
5882 ts
= CLASS_DATA (sym
)->ts
;
5886 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5887 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5888 else if (ts
.type
== BT_CHARACTER
)
5890 if (ts
.u
.cl
->length
== NULL
)
5892 /* Assumed character length results are not allowed by 5.1.1.5 of the
5893 standard and are trapped in resolve.c; except in the case of SPREAD
5894 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5895 we take the character length of the first argument for the result.
5896 For dummies, we have to look through the formal argument list for
5897 this function and use the character length found there.*/
5899 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5900 else if (!sym
->attr
.dummy
)
5901 cl
.backend_decl
= (*stringargs
)[0];
5904 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5905 for (; formal
; formal
= formal
->next
)
5906 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5907 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5909 len
= cl
.backend_decl
;
5915 /* Calculate the length of the returned string. */
5916 gfc_init_se (&parmse
, NULL
);
5917 if (need_interface_mapping
)
5918 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5920 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5921 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5922 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5924 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5925 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5926 gfc_charlen_type_node
, tmp
,
5927 build_int_cst (gfc_charlen_type_node
, 0));
5928 cl
.backend_decl
= tmp
;
5931 /* Set up a charlen structure for it. */
5936 len
= cl
.backend_decl
;
5939 byref
= (comp
&& (comp
->attr
.dimension
5940 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5941 || (!comp
&& gfc_return_by_reference (sym
));
5944 if (se
->direct_byref
)
5946 /* Sometimes, too much indirection can be applied; e.g. for
5947 function_result = array_valued_recursive_function. */
5948 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5949 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5950 && GFC_DESCRIPTOR_TYPE_P
5951 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5952 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5955 /* If the lhs of an assignment x = f(..) is allocatable and
5956 f2003 is allowed, we must do the automatic reallocation.
5957 TODO - deal with intrinsics, without using a temporary. */
5958 if (flag_realloc_lhs
5959 && se
->ss
&& se
->ss
->loop_chain
5960 && se
->ss
->loop_chain
->is_alloc_lhs
5961 && !expr
->value
.function
.isym
5962 && sym
->result
->as
!= NULL
)
5964 /* Evaluate the bounds of the result, if known. */
5965 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5968 /* Perform the automatic reallocation. */
5969 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5971 gfc_add_expr_to_block (&se
->pre
, tmp
);
5973 /* Pass the temporary as the first argument. */
5974 result
= info
->descriptor
;
5977 result
= build_fold_indirect_ref_loc (input_location
,
5979 vec_safe_push (retargs
, se
->expr
);
5981 else if (comp
&& comp
->attr
.dimension
)
5983 gcc_assert (se
->loop
&& info
);
5985 /* Set the type of the array. */
5986 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5987 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5989 /* Evaluate the bounds of the result, if known. */
5990 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5992 /* If the lhs of an assignment x = f(..) is allocatable and
5993 f2003 is allowed, we must not generate the function call
5994 here but should just send back the results of the mapping.
5995 This is signalled by the function ss being flagged. */
5996 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5998 gfc_free_interface_mapping (&mapping
);
5999 return has_alternate_specifier
;
6002 /* Create a temporary to store the result. In case the function
6003 returns a pointer, the temporary will be a shallow copy and
6004 mustn't be deallocated. */
6005 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6006 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6007 tmp
, NULL_TREE
, false,
6008 !comp
->attr
.pointer
, callee_alloc
,
6009 &se
->ss
->info
->expr
->where
);
6011 /* Pass the temporary as the first argument. */
6012 result
= info
->descriptor
;
6013 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6014 vec_safe_push (retargs
, tmp
);
6016 else if (!comp
&& sym
->result
->attr
.dimension
)
6018 gcc_assert (se
->loop
&& info
);
6020 /* Set the type of the array. */
6021 tmp
= gfc_typenode_for_spec (&ts
);
6022 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6024 /* Evaluate the bounds of the result, if known. */
6025 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6027 /* If the lhs of an assignment x = f(..) is allocatable and
6028 f2003 is allowed, we must not generate the function call
6029 here but should just send back the results of the mapping.
6030 This is signalled by the function ss being flagged. */
6031 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6033 gfc_free_interface_mapping (&mapping
);
6034 return has_alternate_specifier
;
6037 /* Create a temporary to store the result. In case the function
6038 returns a pointer, the temporary will be a shallow copy and
6039 mustn't be deallocated. */
6040 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6041 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6042 tmp
, NULL_TREE
, false,
6043 !sym
->attr
.pointer
, callee_alloc
,
6044 &se
->ss
->info
->expr
->where
);
6046 /* Pass the temporary as the first argument. */
6047 result
= info
->descriptor
;
6048 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6049 vec_safe_push (retargs
, tmp
);
6051 else if (ts
.type
== BT_CHARACTER
)
6053 /* Pass the string length. */
6054 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6055 type
= build_pointer_type (type
);
6057 /* Emit a DECL_EXPR for the VLA type. */
6058 tmp
= TREE_TYPE (type
);
6060 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6062 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6063 DECL_ARTIFICIAL (tmp
) = 1;
6064 DECL_IGNORED_P (tmp
) = 1;
6065 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6066 TREE_TYPE (tmp
), tmp
);
6067 gfc_add_expr_to_block (&se
->pre
, tmp
);
6070 /* Return an address to a char[0:len-1]* temporary for
6071 character pointers. */
6072 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6073 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6075 var
= gfc_create_var (type
, "pstr");
6077 if ((!comp
&& sym
->attr
.allocatable
)
6078 || (comp
&& comp
->attr
.allocatable
))
6080 gfc_add_modify (&se
->pre
, var
,
6081 fold_convert (TREE_TYPE (var
),
6082 null_pointer_node
));
6083 tmp
= gfc_call_free (var
);
6084 gfc_add_expr_to_block (&se
->post
, tmp
);
6087 /* Provide an address expression for the function arguments. */
6088 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6091 var
= gfc_conv_string_tmp (se
, type
, len
);
6093 vec_safe_push (retargs
, var
);
6097 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6099 type
= gfc_get_complex_type (ts
.kind
);
6100 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6101 vec_safe_push (retargs
, var
);
6104 /* Add the string length to the argument list. */
6105 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6109 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6110 TREE_STATIC (tmp
) = 1;
6111 gfc_add_modify (&se
->pre
, tmp
,
6112 build_int_cst (TREE_TYPE (tmp
), 0));
6113 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6114 vec_safe_push (retargs
, tmp
);
6116 else if (ts
.type
== BT_CHARACTER
)
6117 vec_safe_push (retargs
, len
);
6119 gfc_free_interface_mapping (&mapping
);
6121 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6122 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6123 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6124 vec_safe_reserve (retargs
, arglen
);
6126 /* Add the return arguments. */
6127 vec_safe_splice (retargs
, arglist
);
6129 /* Add the hidden present status for optional+value to the arguments. */
6130 vec_safe_splice (retargs
, optionalargs
);
6132 /* Add the hidden string length parameters to the arguments. */
6133 vec_safe_splice (retargs
, stringargs
);
6135 /* We may want to append extra arguments here. This is used e.g. for
6136 calls to libgfortran_matmul_??, which need extra information. */
6137 vec_safe_splice (retargs
, append_args
);
6141 /* Generate the actual call. */
6142 if (base_object
== NULL_TREE
)
6143 conv_function_val (se
, sym
, expr
);
6145 conv_base_obj_fcn_val (se
, base_object
, expr
);
6147 /* If there are alternate return labels, function type should be
6148 integer. Can't modify the type in place though, since it can be shared
6149 with other functions. For dummy arguments, the typing is done to
6150 this result, even if it has to be repeated for each call. */
6151 if (has_alternate_specifier
6152 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6154 if (!sym
->attr
.dummy
)
6156 TREE_TYPE (sym
->backend_decl
)
6157 = build_function_type (integer_type_node
,
6158 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6159 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6162 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6165 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6166 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6168 /* Allocatable scalar function results must be freed and nullified
6169 after use. This necessitates the creation of a temporary to
6170 hold the result to prevent duplicate calls. */
6171 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6172 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6173 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6175 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6176 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6178 tmp
= gfc_call_free (tmp
);
6179 gfc_add_expr_to_block (&post
, tmp
);
6180 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6183 /* If we have a pointer function, but we don't want a pointer, e.g.
6186 where f is pointer valued, we have to dereference the result. */
6187 if (!se
->want_pointer
&& !byref
6188 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6189 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6190 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6192 /* f2c calling conventions require a scalar default real function to
6193 return a double precision result. Convert this back to default
6194 real. We only care about the cases that can happen in Fortran 77.
6196 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6197 && sym
->ts
.kind
== gfc_default_real_kind
6198 && !sym
->attr
.always_explicit
)
6199 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6201 /* A pure function may still have side-effects - it may modify its
6203 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6205 if (!sym
->attr
.pure
)
6206 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6211 /* Add the function call to the pre chain. There is no expression. */
6212 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6213 se
->expr
= NULL_TREE
;
6215 if (!se
->direct_byref
)
6217 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6219 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6221 /* Check the data pointer hasn't been modified. This would
6222 happen in a function returning a pointer. */
6223 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6224 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6227 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6230 se
->expr
= info
->descriptor
;
6231 /* Bundle in the string length. */
6232 se
->string_length
= len
;
6234 else if (ts
.type
== BT_CHARACTER
)
6236 /* Dereference for character pointer results. */
6237 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6238 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6239 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6243 se
->string_length
= len
;
6247 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6248 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6253 /* Associate the rhs class object's meta-data with the result, when the
6254 result is a temporary. */
6255 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6256 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6257 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6260 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6262 gfc_init_se (&parmse
, NULL
);
6263 parmse
.data_not_needed
= 1;
6264 gfc_conv_expr (&parmse
, class_expr
);
6265 if (!DECL_LANG_SPECIFIC (result
))
6266 gfc_allocate_lang_decl (result
);
6267 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6268 gfc_free_expr (class_expr
);
6269 gcc_assert (parmse
.pre
.head
== NULL_TREE
6270 && parmse
.post
.head
== NULL_TREE
);
6273 /* Follow the function call with the argument post block. */
6276 gfc_add_block_to_block (&se
->pre
, &post
);
6278 /* Transformational functions of derived types with allocatable
6279 components must have the result allocatable components copied when the
6280 argument is actually given. */
6281 arg
= expr
->value
.function
.actual
;
6282 if (result
&& arg
&& expr
->rank
6283 && expr
->value
.function
.isym
6284 && expr
->value
.function
.isym
->transformational
6286 && arg
->expr
->ts
.type
== BT_DERIVED
6287 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6290 /* Copy the allocatable components. We have to use a
6291 temporary here to prevent source allocatable components
6292 from being corrupted. */
6293 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6294 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6295 result
, tmp2
, expr
->rank
, 0);
6296 gfc_add_expr_to_block (&se
->pre
, tmp
);
6297 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6299 gfc_add_expr_to_block (&se
->pre
, tmp
);
6301 /* Finally free the temporary's data field. */
6302 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6303 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6304 NULL_TREE
, NULL_TREE
, true,
6305 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6306 gfc_add_expr_to_block (&se
->pre
, tmp
);
6311 /* For a function with a class array result, save the result as
6312 a temporary, set the info fields needed by the scalarizer and
6313 call the finalization function of the temporary. Note that the
6314 nullification of allocatable components needed by the result
6315 is done in gfc_trans_assignment_1. */
6316 if (expr
&& ((gfc_is_class_array_function (expr
)
6317 && se
->ss
&& se
->ss
->loop
)
6318 || gfc_is_alloc_class_scalar_function (expr
))
6319 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6320 && expr
->must_finalize
)
6325 if (se
->ss
&& se
->ss
->loop
)
6327 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
6328 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6329 tmp
= gfc_class_data_get (se
->expr
);
6330 info
->descriptor
= tmp
;
6331 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6332 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6333 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6335 tree dim
= gfc_rank_cst
[n
];
6336 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6337 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6342 /* TODO Eliminate the doubling of temporaries. This
6343 one is necessary to ensure no memory leakage. */
6344 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6345 tmp
= gfc_class_data_get (se
->expr
);
6346 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6347 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6350 if ((gfc_is_class_array_function (expr
)
6351 || gfc_is_alloc_class_scalar_function (expr
))
6352 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
6353 goto no_finalization
;
6355 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6356 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6359 fold_convert (TREE_TYPE (final_fndecl
),
6360 null_pointer_node
));
6361 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6363 tmp
= build_call_expr_loc (input_location
,
6365 gfc_build_addr_expr (NULL
, tmp
),
6366 gfc_class_vtab_size_get (se
->expr
),
6367 boolean_false_node
);
6368 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6369 void_type_node
, is_final
, tmp
,
6370 build_empty_stmt (input_location
));
6372 if (se
->ss
&& se
->ss
->loop
)
6374 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6375 tmp
= gfc_call_free (info
->data
);
6376 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6380 gfc_add_expr_to_block (&se
->post
, tmp
);
6381 tmp
= gfc_class_data_get (se
->expr
);
6382 tmp
= gfc_call_free (tmp
);
6383 gfc_add_expr_to_block (&se
->post
, tmp
);
6387 expr
->must_finalize
= 0;
6390 gfc_add_block_to_block (&se
->post
, &post
);
6393 return has_alternate_specifier
;
6397 /* Fill a character string with spaces. */
6400 fill_with_spaces (tree start
, tree type
, tree size
)
6402 stmtblock_t block
, loop
;
6403 tree i
, el
, exit_label
, cond
, tmp
;
6405 /* For a simple char type, we can call memset(). */
6406 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6407 return build_call_expr_loc (input_location
,
6408 builtin_decl_explicit (BUILT_IN_MEMSET
),
6410 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6411 lang_hooks
.to_target_charset (' ')),
6414 /* Otherwise, we use a loop:
6415 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6419 /* Initialize variables. */
6420 gfc_init_block (&block
);
6421 i
= gfc_create_var (sizetype
, "i");
6422 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6423 el
= gfc_create_var (build_pointer_type (type
), "el");
6424 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6425 exit_label
= gfc_build_label_decl (NULL_TREE
);
6426 TREE_USED (exit_label
) = 1;
6430 gfc_init_block (&loop
);
6432 /* Exit condition. */
6433 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6434 build_zero_cst (sizetype
));
6435 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6436 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6437 build_empty_stmt (input_location
));
6438 gfc_add_expr_to_block (&loop
, tmp
);
6441 gfc_add_modify (&loop
,
6442 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6443 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6445 /* Increment loop variables. */
6446 gfc_add_modify (&loop
, i
,
6447 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6448 TYPE_SIZE_UNIT (type
)));
6449 gfc_add_modify (&loop
, el
,
6450 fold_build_pointer_plus_loc (input_location
,
6451 el
, TYPE_SIZE_UNIT (type
)));
6453 /* Making the loop... actually loop! */
6454 tmp
= gfc_finish_block (&loop
);
6455 tmp
= build1_v (LOOP_EXPR
, tmp
);
6456 gfc_add_expr_to_block (&block
, tmp
);
6458 /* The exit label. */
6459 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6460 gfc_add_expr_to_block (&block
, tmp
);
6463 return gfc_finish_block (&block
);
6467 /* Generate code to copy a string. */
6470 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6471 int dkind
, tree slength
, tree src
, int skind
)
6473 tree tmp
, dlen
, slen
;
6482 stmtblock_t tempblock
;
6484 gcc_assert (dkind
== skind
);
6486 if (slength
!= NULL_TREE
)
6488 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6489 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6493 slen
= build_int_cst (size_type_node
, 1);
6497 if (dlength
!= NULL_TREE
)
6499 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6500 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6504 dlen
= build_int_cst (size_type_node
, 1);
6508 /* Assign directly if the types are compatible. */
6509 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6510 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6512 gfc_add_modify (block
, dsc
, ssc
);
6516 /* The string copy algorithm below generates code like
6519 memmove (dest, src, min(dlen, slen));
6521 memset(&dest[slen], ' ', dlen - slen);
6525 /* Do nothing if the destination length is zero. */
6526 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6527 build_int_cst (size_type_node
, 0));
6529 /* For non-default character kinds, we have to multiply the string
6530 length by the base type size. */
6531 chartype
= gfc_get_char_type (dkind
);
6532 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6533 fold_convert (size_type_node
, slen
),
6534 fold_convert (size_type_node
,
6535 TYPE_SIZE_UNIT (chartype
)));
6536 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6537 fold_convert (size_type_node
, dlen
),
6538 fold_convert (size_type_node
,
6539 TYPE_SIZE_UNIT (chartype
)));
6541 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6542 dest
= fold_convert (pvoid_type_node
, dest
);
6544 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6546 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6547 src
= fold_convert (pvoid_type_node
, src
);
6549 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6551 /* First do the memmove. */
6552 tmp2
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (dlen
), dlen
,
6554 tmp2
= build_call_expr_loc (input_location
,
6555 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6556 3, dest
, src
, tmp2
);
6557 stmtblock_t tmpblock2
;
6558 gfc_init_block (&tmpblock2
);
6559 gfc_add_expr_to_block (&tmpblock2
, tmp2
);
6561 /* If the destination is longer, fill the end with spaces. */
6562 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6565 /* Wstringop-overflow appears at -O3 even though this warning is not
6566 explicitly available in fortran nor can it be switched off. If the
6567 source length is a constant, its negative appears as a very large
6568 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6569 the result of the MINUS_EXPR suppresses this spurious warning. */
6570 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6571 TREE_TYPE(dlen
), dlen
, slen
);
6572 if (slength
&& TREE_CONSTANT (slength
))
6573 tmp
= gfc_evaluate_now (tmp
, block
);
6575 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6576 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6578 gfc_init_block (&tempblock
);
6579 gfc_add_expr_to_block (&tempblock
, tmp4
);
6580 tmp3
= gfc_finish_block (&tempblock
);
6582 /* The whole copy_string function is there. */
6583 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6584 tmp3
, build_empty_stmt (input_location
));
6585 gfc_add_expr_to_block (&tmpblock2
, tmp
);
6586 tmp
= gfc_finish_block (&tmpblock2
);
6587 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6588 build_empty_stmt (input_location
));
6589 gfc_add_expr_to_block (block
, tmp
);
6593 /* Translate a statement function.
6594 The value of a statement function reference is obtained by evaluating the
6595 expression using the values of the actual arguments for the values of the
6596 corresponding dummy arguments. */
6599 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6603 gfc_formal_arglist
*fargs
;
6604 gfc_actual_arglist
*args
;
6607 gfc_saved_var
*saved_vars
;
6613 sym
= expr
->symtree
->n
.sym
;
6614 args
= expr
->value
.function
.actual
;
6615 gfc_init_se (&lse
, NULL
);
6616 gfc_init_se (&rse
, NULL
);
6619 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6621 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6622 temp_vars
= XCNEWVEC (tree
, n
);
6624 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6625 fargs
= fargs
->next
, n
++)
6627 /* Each dummy shall be specified, explicitly or implicitly, to be
6629 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6632 if (fsym
->ts
.type
== BT_CHARACTER
)
6634 /* Copy string arguments. */
6637 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6638 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6640 /* Create a temporary to hold the value. */
6641 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6642 fsym
->ts
.u
.cl
->backend_decl
6643 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6645 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6646 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6648 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6650 gfc_conv_expr (&rse
, args
->expr
);
6651 gfc_conv_string_parameter (&rse
);
6652 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6653 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6655 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6656 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6657 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6658 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6662 /* For everything else, just evaluate the expression. */
6664 /* Create a temporary to hold the value. */
6665 type
= gfc_typenode_for_spec (&fsym
->ts
);
6666 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6668 gfc_conv_expr (&lse
, args
->expr
);
6670 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6671 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6672 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6678 /* Use the temporary variables in place of the real ones. */
6679 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6680 fargs
= fargs
->next
, n
++)
6681 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6683 gfc_conv_expr (se
, sym
->value
);
6685 if (sym
->ts
.type
== BT_CHARACTER
)
6687 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6689 /* Force the expression to the correct length. */
6690 if (!INTEGER_CST_P (se
->string_length
)
6691 || tree_int_cst_lt (se
->string_length
,
6692 sym
->ts
.u
.cl
->backend_decl
))
6694 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6695 tmp
= gfc_create_var (type
, sym
->name
);
6696 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6697 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6698 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6702 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6705 /* Restore the original variables. */
6706 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6707 fargs
= fargs
->next
, n
++)
6708 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6714 /* Translate a function expression. */
6717 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6721 if (expr
->value
.function
.isym
)
6723 gfc_conv_intrinsic_function (se
, expr
);
6727 /* expr.value.function.esym is the resolved (specific) function symbol for
6728 most functions. However this isn't set for dummy procedures. */
6729 sym
= expr
->value
.function
.esym
;
6731 sym
= expr
->symtree
->n
.sym
;
6733 /* The IEEE_ARITHMETIC functions are caught here. */
6734 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6735 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6738 /* We distinguish statement functions from general functions to improve
6739 runtime performance. */
6740 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6742 gfc_conv_statement_function (se
, expr
);
6746 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6751 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6754 is_zero_initializer_p (gfc_expr
* expr
)
6756 if (expr
->expr_type
!= EXPR_CONSTANT
)
6759 /* We ignore constants with prescribed memory representations for now. */
6760 if (expr
->representation
.string
)
6763 switch (expr
->ts
.type
)
6766 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6769 return mpfr_zero_p (expr
->value
.real
)
6770 && MPFR_SIGN (expr
->value
.real
) >= 0;
6773 return expr
->value
.logical
== 0;
6776 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6777 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6778 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6779 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6789 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6794 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6795 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6797 gfc_conv_tmp_array_ref (se
);
6801 /* Build a static initializer. EXPR is the expression for the initial value.
6802 The other parameters describe the variable of the component being
6803 initialized. EXPR may be null. */
6806 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6807 bool array
, bool pointer
, bool procptr
)
6811 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6812 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6813 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6814 return build_constructor (type
, NULL
);
6816 if (!(expr
|| pointer
|| procptr
))
6819 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6820 (these are the only two iso_c_binding derived types that can be
6821 used as initialization expressions). If so, we need to modify
6822 the 'expr' to be that for a (void *). */
6823 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6824 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6826 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6828 /* The derived symbol has already been converted to a (void *). Use
6830 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6831 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6833 gfc_init_se (&se
, NULL
);
6834 gfc_conv_constant (&se
, expr
);
6835 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6839 if (array
&& !procptr
)
6842 /* Arrays need special handling. */
6844 ctor
= gfc_build_null_descriptor (type
);
6845 /* Special case assigning an array to zero. */
6846 else if (is_zero_initializer_p (expr
))
6847 ctor
= build_constructor (type
, NULL
);
6849 ctor
= gfc_conv_array_initializer (type
, expr
);
6850 TREE_STATIC (ctor
) = 1;
6853 else if (pointer
|| procptr
)
6855 if (ts
->type
== BT_CLASS
&& !procptr
)
6857 gfc_init_se (&se
, NULL
);
6858 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6859 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6860 TREE_STATIC (se
.expr
) = 1;
6863 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6864 return fold_convert (type
, null_pointer_node
);
6867 gfc_init_se (&se
, NULL
);
6868 se
.want_pointer
= 1;
6869 gfc_conv_expr (&se
, expr
);
6870 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6880 gfc_init_se (&se
, NULL
);
6881 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6882 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6884 gfc_conv_structure (&se
, expr
, 1);
6885 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6886 TREE_STATIC (se
.expr
) = 1;
6891 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6892 TREE_STATIC (ctor
) = 1;
6897 gfc_init_se (&se
, NULL
);
6898 gfc_conv_constant (&se
, expr
);
6899 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6906 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6912 gfc_array_info
*lss_array
;
6919 gfc_start_block (&block
);
6921 /* Initialize the scalarizer. */
6922 gfc_init_loopinfo (&loop
);
6924 gfc_init_se (&lse
, NULL
);
6925 gfc_init_se (&rse
, NULL
);
6928 rss
= gfc_walk_expr (expr
);
6929 if (rss
== gfc_ss_terminator
)
6930 /* The rhs is scalar. Add a ss for the expression. */
6931 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6933 /* Create a SS for the destination. */
6934 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6936 lss_array
= &lss
->info
->data
.array
;
6937 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6938 lss_array
->descriptor
= dest
;
6939 lss_array
->data
= gfc_conv_array_data (dest
);
6940 lss_array
->offset
= gfc_conv_array_offset (dest
);
6941 for (n
= 0; n
< cm
->as
->rank
; n
++)
6943 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6944 lss_array
->stride
[n
] = gfc_index_one_node
;
6946 mpz_init (lss_array
->shape
[n
]);
6947 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6948 cm
->as
->lower
[n
]->value
.integer
);
6949 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6952 /* Associate the SS with the loop. */
6953 gfc_add_ss_to_loop (&loop
, lss
);
6954 gfc_add_ss_to_loop (&loop
, rss
);
6956 /* Calculate the bounds of the scalarization. */
6957 gfc_conv_ss_startstride (&loop
);
6959 /* Setup the scalarizing loops. */
6960 gfc_conv_loop_setup (&loop
, &expr
->where
);
6962 /* Setup the gfc_se structures. */
6963 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6964 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6967 gfc_mark_ss_chain_used (rss
, 1);
6969 gfc_mark_ss_chain_used (lss
, 1);
6971 /* Start the scalarized loop body. */
6972 gfc_start_scalarized_body (&loop
, &body
);
6974 gfc_conv_tmp_array_ref (&lse
);
6975 if (cm
->ts
.type
== BT_CHARACTER
)
6976 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6978 gfc_conv_expr (&rse
, expr
);
6980 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6981 gfc_add_expr_to_block (&body
, tmp
);
6983 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6985 /* Generate the copying loops. */
6986 gfc_trans_scalarizing_loops (&loop
, &body
);
6988 /* Wrap the whole thing up. */
6989 gfc_add_block_to_block (&block
, &loop
.pre
);
6990 gfc_add_block_to_block (&block
, &loop
.post
);
6992 gcc_assert (lss_array
->shape
!= NULL
);
6993 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6994 gfc_cleanup_loop (&loop
);
6996 return gfc_finish_block (&block
);
7001 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7011 gfc_expr
*arg
= NULL
;
7013 gfc_start_block (&block
);
7014 gfc_init_se (&se
, NULL
);
7016 /* Get the descriptor for the expressions. */
7017 se
.want_pointer
= 0;
7018 gfc_conv_expr_descriptor (&se
, expr
);
7019 gfc_add_block_to_block (&block
, &se
.pre
);
7020 gfc_add_modify (&block
, dest
, se
.expr
);
7022 /* Deal with arrays of derived types with allocatable components. */
7023 if (gfc_bt_struct (cm
->ts
.type
)
7024 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7025 // TODO: Fix caf_mode
7026 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7029 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7030 && CLASS_DATA(cm
)->attr
.allocatable
)
7032 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7033 // TODO: Fix caf_mode
7034 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7039 tmp
= TREE_TYPE (dest
);
7040 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7041 tmp
, expr
->rank
, NULL_TREE
);
7045 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7046 TREE_TYPE(cm
->backend_decl
),
7047 cm
->as
->rank
, NULL_TREE
);
7049 gfc_add_expr_to_block (&block
, tmp
);
7050 gfc_add_block_to_block (&block
, &se
.post
);
7052 if (expr
->expr_type
!= EXPR_VARIABLE
)
7053 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7056 /* We need to know if the argument of a conversion function is a
7057 variable, so that the correct lower bound can be used. */
7058 if (expr
->expr_type
== EXPR_FUNCTION
7059 && expr
->value
.function
.isym
7060 && expr
->value
.function
.isym
->conversion
7061 && expr
->value
.function
.actual
->expr
7062 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7063 arg
= expr
->value
.function
.actual
->expr
;
7065 /* Obtain the array spec of full array references. */
7067 as
= gfc_get_full_arrayspec_from_expr (arg
);
7069 as
= gfc_get_full_arrayspec_from_expr (expr
);
7071 /* Shift the lbound and ubound of temporaries to being unity,
7072 rather than zero, based. Always calculate the offset. */
7073 offset
= gfc_conv_descriptor_offset_get (dest
);
7074 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7075 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7077 for (n
= 0; n
< expr
->rank
; n
++)
7082 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7083 TODO It looks as if gfc_conv_expr_descriptor should return
7084 the correct bounds and that the following should not be
7085 necessary. This would simplify gfc_conv_intrinsic_bound
7087 if (as
&& as
->lower
[n
])
7090 gfc_init_se (&lbse
, NULL
);
7091 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7092 gfc_add_block_to_block (&block
, &lbse
.pre
);
7093 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7097 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7098 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7102 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7105 lbound
= gfc_index_one_node
;
7107 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7109 /* Shift the bounds and set the offset accordingly. */
7110 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7111 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7112 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7113 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7115 gfc_conv_descriptor_ubound_set (&block
, dest
,
7116 gfc_rank_cst
[n
], tmp
);
7117 gfc_conv_descriptor_lbound_set (&block
, dest
,
7118 gfc_rank_cst
[n
], lbound
);
7120 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7121 gfc_conv_descriptor_lbound_get (dest
,
7123 gfc_conv_descriptor_stride_get (dest
,
7125 gfc_add_modify (&block
, tmp2
, tmp
);
7126 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7128 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7133 /* If a conversion expression has a null data pointer
7134 argument, nullify the allocatable component. */
7138 if (arg
->symtree
->n
.sym
->attr
.allocatable
7139 || arg
->symtree
->n
.sym
->attr
.pointer
)
7141 non_null_expr
= gfc_finish_block (&block
);
7142 gfc_start_block (&block
);
7143 gfc_conv_descriptor_data_set (&block
, dest
,
7145 null_expr
= gfc_finish_block (&block
);
7146 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7147 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7148 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7149 return build3_v (COND_EXPR
, tmp
,
7150 null_expr
, non_null_expr
);
7154 return gfc_finish_block (&block
);
7158 /* Allocate or reallocate scalar component, as necessary. */
7161 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7171 tree lhs_cl_size
= NULL_TREE
;
7176 if (!expr2
|| expr2
->rank
)
7179 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7181 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7183 char name
[GFC_MAX_SYMBOL_LEN
+9];
7184 gfc_component
*strlen
;
7185 /* Use the rhs string length and the lhs element size. */
7186 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7187 if (!expr2
->ts
.u
.cl
->backend_decl
)
7189 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7190 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7193 size
= expr2
->ts
.u
.cl
->backend_decl
;
7195 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7197 sprintf (name
, "_%s_length", cm
->name
);
7198 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7199 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7200 gfc_charlen_type_node
,
7201 TREE_OPERAND (comp
, 0),
7202 strlen
->backend_decl
, NULL_TREE
);
7204 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7205 tmp
= TYPE_SIZE_UNIT (tmp
);
7206 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7207 TREE_TYPE (tmp
), tmp
,
7208 fold_convert (TREE_TYPE (tmp
), size
));
7210 else if (cm
->ts
.type
== BT_CLASS
)
7212 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7213 if (expr2
->ts
.type
== BT_DERIVED
)
7215 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7216 size
= TYPE_SIZE_UNIT (tmp
);
7222 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7223 gfc_add_vptr_component (e2vtab
);
7224 gfc_add_size_component (e2vtab
);
7225 gfc_init_se (&se
, NULL
);
7226 gfc_conv_expr (&se
, e2vtab
);
7227 gfc_add_block_to_block (block
, &se
.pre
);
7228 size
= fold_convert (size_type_node
, se
.expr
);
7229 gfc_free_expr (e2vtab
);
7231 size_in_bytes
= size
;
7235 /* Otherwise use the length in bytes of the rhs. */
7236 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7237 size_in_bytes
= size
;
7240 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7241 size_in_bytes
, size_one_node
);
7243 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7245 tmp
= build_call_expr_loc (input_location
,
7246 builtin_decl_explicit (BUILT_IN_CALLOC
),
7247 2, build_one_cst (size_type_node
),
7249 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7250 gfc_add_modify (block
, comp
, tmp
);
7254 tmp
= build_call_expr_loc (input_location
,
7255 builtin_decl_explicit (BUILT_IN_MALLOC
),
7257 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7258 ptr
= gfc_class_data_get (comp
);
7261 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7262 gfc_add_modify (block
, ptr
, tmp
);
7265 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7266 /* Update the lhs character length. */
7267 gfc_add_modify (block
, lhs_cl_size
, size
);
7271 /* Assign a single component of a derived type constructor. */
7274 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7275 gfc_symbol
*sym
, bool init
)
7283 gfc_start_block (&block
);
7285 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7287 /* Only care about pointers here, not about allocatables. */
7288 gfc_init_se (&se
, NULL
);
7289 /* Pointer component. */
7290 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7291 && !cm
->attr
.proc_pointer
)
7293 /* Array pointer. */
7294 if (expr
->expr_type
== EXPR_NULL
)
7295 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7298 se
.direct_byref
= 1;
7300 gfc_conv_expr_descriptor (&se
, expr
);
7301 gfc_add_block_to_block (&block
, &se
.pre
);
7302 gfc_add_block_to_block (&block
, &se
.post
);
7307 /* Scalar pointers. */
7308 se
.want_pointer
= 1;
7309 gfc_conv_expr (&se
, expr
);
7310 gfc_add_block_to_block (&block
, &se
.pre
);
7312 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7313 && expr
->symtree
->n
.sym
->attr
.dummy
)
7314 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7316 gfc_add_modify (&block
, dest
,
7317 fold_convert (TREE_TYPE (dest
), se
.expr
));
7318 gfc_add_block_to_block (&block
, &se
.post
);
7321 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7323 /* NULL initialization for CLASS components. */
7324 tmp
= gfc_trans_structure_assign (dest
,
7325 gfc_class_initializer (&cm
->ts
, expr
),
7327 gfc_add_expr_to_block (&block
, tmp
);
7329 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7330 && !cm
->attr
.proc_pointer
)
7332 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7333 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7334 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7336 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7337 gfc_add_expr_to_block (&block
, tmp
);
7341 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7342 gfc_add_expr_to_block (&block
, tmp
);
7345 else if (cm
->ts
.type
== BT_CLASS
7346 && CLASS_DATA (cm
)->attr
.dimension
7347 && CLASS_DATA (cm
)->attr
.allocatable
7348 && expr
->ts
.type
== BT_DERIVED
)
7350 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7351 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7352 tmp
= gfc_class_vptr_get (dest
);
7353 gfc_add_modify (&block
, tmp
,
7354 fold_convert (TREE_TYPE (tmp
), vtab
));
7355 tmp
= gfc_class_data_get (dest
);
7356 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7357 gfc_add_expr_to_block (&block
, tmp
);
7359 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7361 /* NULL initialization for allocatable components. */
7362 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7363 null_pointer_node
));
7365 else if (init
&& (cm
->attr
.allocatable
7366 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7367 && expr
->ts
.type
!= BT_CLASS
)))
7369 /* Take care about non-array allocatable components here. The alloc_*
7370 routine below is motivated by the alloc_scalar_allocatable_for_
7371 assignment() routine, but with the realloc portions removed and
7373 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7378 /* The remainder of these instructions follow the if (cm->attr.pointer)
7379 if (!cm->attr.dimension) part above. */
7380 gfc_init_se (&se
, NULL
);
7381 gfc_conv_expr (&se
, expr
);
7382 gfc_add_block_to_block (&block
, &se
.pre
);
7384 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7385 && expr
->symtree
->n
.sym
->attr
.dummy
)
7386 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7388 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7390 tmp
= gfc_class_data_get (dest
);
7391 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7392 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7393 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7394 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7395 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7398 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7400 /* For deferred strings insert a memcpy. */
7401 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7404 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7405 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7407 : expr
->ts
.u
.cl
->backend_decl
);
7408 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7409 gfc_add_expr_to_block (&block
, tmp
);
7412 gfc_add_modify (&block
, tmp
,
7413 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7414 gfc_add_block_to_block (&block
, &se
.post
);
7416 else if (expr
->ts
.type
== BT_UNION
)
7419 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7420 /* We mark that the entire union should be initialized with a contrived
7421 EXPR_NULL expression at the beginning. */
7422 if (c
!= NULL
&& c
->n
.component
== NULL
7423 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7425 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7426 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7427 gfc_add_expr_to_block (&block
, tmp
);
7428 c
= gfc_constructor_next (c
);
7430 /* The following constructor expression, if any, represents a specific
7431 map intializer, as given by the user. */
7432 if (c
!= NULL
&& c
->expr
!= NULL
)
7434 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7435 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7436 gfc_add_expr_to_block (&block
, tmp
);
7439 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7441 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7443 tree dealloc
= NULL_TREE
;
7444 gfc_init_se (&se
, NULL
);
7445 gfc_conv_expr (&se
, expr
);
7446 gfc_add_block_to_block (&block
, &se
.pre
);
7447 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7448 expression in a temporary variable and deallocate the allocatable
7449 components. Then we can the copy the expression to the result. */
7450 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7451 && expr
->expr_type
!= EXPR_VARIABLE
)
7453 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7454 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7457 gfc_add_modify (&block
, dest
,
7458 fold_convert (TREE_TYPE (dest
), se
.expr
));
7459 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7460 && expr
->expr_type
!= EXPR_NULL
)
7462 // TODO: Fix caf_mode
7463 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7464 dest
, expr
->rank
, 0);
7465 gfc_add_expr_to_block (&block
, tmp
);
7466 if (dealloc
!= NULL_TREE
)
7467 gfc_add_expr_to_block (&block
, dealloc
);
7469 gfc_add_block_to_block (&block
, &se
.post
);
7473 /* Nested constructors. */
7474 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7475 gfc_add_expr_to_block (&block
, tmp
);
7478 else if (gfc_deferred_strlen (cm
, &tmp
))
7482 gcc_assert (strlen
);
7483 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7485 TREE_OPERAND (dest
, 0),
7488 if (expr
->expr_type
== EXPR_NULL
)
7490 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7491 gfc_add_modify (&block
, dest
, tmp
);
7492 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7493 gfc_add_modify (&block
, strlen
, tmp
);
7498 gfc_init_se (&se
, NULL
);
7499 gfc_conv_expr (&se
, expr
);
7500 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7501 tmp
= build_call_expr_loc (input_location
,
7502 builtin_decl_explicit (BUILT_IN_MALLOC
),
7504 gfc_add_modify (&block
, dest
,
7505 fold_convert (TREE_TYPE (dest
), tmp
));
7506 gfc_add_modify (&block
, strlen
, se
.string_length
);
7507 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7508 gfc_add_expr_to_block (&block
, tmp
);
7511 else if (!cm
->attr
.artificial
)
7513 /* Scalar component (excluding deferred parameters). */
7514 gfc_init_se (&se
, NULL
);
7515 gfc_init_se (&lse
, NULL
);
7517 gfc_conv_expr (&se
, expr
);
7518 if (cm
->ts
.type
== BT_CHARACTER
)
7519 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7521 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7522 gfc_add_expr_to_block (&block
, tmp
);
7524 return gfc_finish_block (&block
);
7527 /* Assign a derived type constructor to a variable. */
7530 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7539 gfc_start_block (&block
);
7540 cm
= expr
->ts
.u
.derived
->components
;
7542 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7543 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7544 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7548 gfc_init_se (&se
, NULL
);
7549 gfc_init_se (&lse
, NULL
);
7550 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7552 gfc_add_modify (&block
, lse
.expr
,
7553 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7555 return gfc_finish_block (&block
);
7559 gfc_init_se (&se
, NULL
);
7561 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7562 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7564 /* Skip absent members in default initializers. */
7565 if (!c
->expr
&& !cm
->attr
.allocatable
)
7568 /* Register the component with the caf-lib before it is initialized.
7569 Register only allocatable components, that are not coarray'ed
7570 components (%comp[*]). Only register when the constructor is not the
7572 if (coarray
&& !cm
->attr
.codimension
7573 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7574 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7576 tree token
, desc
, size
;
7577 bool is_array
= cm
->ts
.type
== BT_CLASS
7578 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7580 field
= cm
->backend_decl
;
7581 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7582 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7583 if (cm
->ts
.type
== BT_CLASS
)
7584 field
= gfc_class_data_get (field
);
7586 token
= is_array
? gfc_conv_descriptor_token (field
)
7587 : fold_build3_loc (input_location
, COMPONENT_REF
,
7588 TREE_TYPE (cm
->caf_token
), dest
,
7589 cm
->caf_token
, NULL_TREE
);
7593 /* The _caf_register routine looks at the rank of the array
7594 descriptor to decide whether the data registered is an array
7596 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7598 /* When the rank is not known just set a positive rank, which
7599 suffices to recognize the data as array. */
7602 size
= integer_zero_node
;
7604 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7605 build_int_cst (gfc_array_index_type
, rank
));
7609 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
7610 cm
->ts
.type
== BT_CLASS
7611 ? CLASS_DATA (cm
)->attr
7613 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7615 gfc_add_block_to_block (&block
, &se
.pre
);
7616 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7617 7, size
, build_int_cst (
7619 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7620 gfc_build_addr_expr (pvoid_type_node
,
7622 gfc_build_addr_expr (NULL_TREE
, desc
),
7623 null_pointer_node
, null_pointer_node
,
7625 gfc_add_expr_to_block (&block
, tmp
);
7627 field
= cm
->backend_decl
;
7628 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7629 dest
, field
, NULL_TREE
);
7632 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7633 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7638 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7639 expr
->ts
.u
.derived
, init
);
7640 gfc_add_expr_to_block (&block
, tmp
);
7642 return gfc_finish_block (&block
);
7646 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7647 gfc_component
*un
, gfc_expr
*init
)
7649 gfc_constructor
*ctor
;
7651 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7654 ctor
= gfc_constructor_first (init
->value
.constructor
);
7656 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7659 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7661 /* If we have an 'initialize all' constructor, do it first. */
7662 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7664 tree union_type
= TREE_TYPE (un
->backend_decl
);
7665 tree val
= build_constructor (union_type
, NULL
);
7666 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7667 ctor
= gfc_constructor_next (ctor
);
7670 /* Add the map initializer on top. */
7671 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7673 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7674 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7675 TREE_TYPE (un
->backend_decl
),
7676 un
->attr
.dimension
, un
->attr
.pointer
,
7677 un
->attr
.proc_pointer
);
7678 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7682 /* Build an expression for a constructor. If init is nonzero then
7683 this is part of a static variable initializer. */
7686 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7693 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7695 gcc_assert (se
->ss
== NULL
);
7696 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7697 type
= gfc_typenode_for_spec (&expr
->ts
);
7701 /* Create a temporary variable and fill it in. */
7702 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7703 /* The symtree in expr is NULL, if the code to generate is for
7704 initializing the static members only. */
7705 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7707 gfc_add_expr_to_block (&se
->pre
, tmp
);
7711 cm
= expr
->ts
.u
.derived
->components
;
7713 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7714 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7716 /* Skip absent members in default initializers and allocatable
7717 components. Although the latter have a default initializer
7718 of EXPR_NULL,... by default, the static nullify is not needed
7719 since this is done every time we come into scope. */
7720 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7723 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7724 && strcmp (cm
->name
, "_extends") == 0
7725 && cm
->initializer
->symtree
)
7729 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7730 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7731 vtab
= unshare_expr_without_location (vtab
);
7732 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7734 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7736 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7737 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7738 fold_convert (TREE_TYPE (cm
->backend_decl
),
7741 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7742 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7743 fold_convert (TREE_TYPE (cm
->backend_decl
),
7744 integer_zero_node
));
7745 else if (cm
->ts
.type
== BT_UNION
)
7746 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7749 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7750 TREE_TYPE (cm
->backend_decl
),
7751 cm
->attr
.dimension
, cm
->attr
.pointer
,
7752 cm
->attr
.proc_pointer
);
7753 val
= unshare_expr_without_location (val
);
7755 /* Append it to the constructor list. */
7756 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7760 se
->expr
= build_constructor (type
, v
);
7762 TREE_CONSTANT (se
->expr
) = 1;
7766 /* Translate a substring expression. */
7769 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7775 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7777 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7778 expr
->value
.character
.length
,
7779 expr
->value
.character
.string
);
7781 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7782 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7785 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7789 /* Entry point for expression translation. Evaluates a scalar quantity.
7790 EXPR is the expression to be translated, and SE is the state structure if
7791 called from within the scalarized. */
7794 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7799 if (ss
&& ss
->info
->expr
== expr
7800 && (ss
->info
->type
== GFC_SS_SCALAR
7801 || ss
->info
->type
== GFC_SS_REFERENCE
))
7803 gfc_ss_info
*ss_info
;
7806 /* Substitute a scalar expression evaluated outside the scalarization
7808 se
->expr
= ss_info
->data
.scalar
.value
;
7809 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7810 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7812 se
->string_length
= ss_info
->string_length
;
7813 gfc_advance_se_ss_chain (se
);
7817 /* We need to convert the expressions for the iso_c_binding derived types.
7818 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7819 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7820 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7821 updated to be an integer with a kind equal to the size of a (void *). */
7822 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7823 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7825 if (expr
->expr_type
== EXPR_VARIABLE
7826 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7827 || expr
->symtree
->n
.sym
->intmod_sym_id
7828 == ISOCBINDING_NULL_FUNPTR
))
7830 /* Set expr_type to EXPR_NULL, which will result in
7831 null_pointer_node being used below. */
7832 expr
->expr_type
= EXPR_NULL
;
7836 /* Update the type/kind of the expression to be what the new
7837 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7838 expr
->ts
.type
= BT_INTEGER
;
7839 expr
->ts
.f90_type
= BT_VOID
;
7840 expr
->ts
.kind
= gfc_index_integer_kind
;
7844 gfc_fix_class_refs (expr
);
7846 switch (expr
->expr_type
)
7849 gfc_conv_expr_op (se
, expr
);
7853 gfc_conv_function_expr (se
, expr
);
7857 gfc_conv_constant (se
, expr
);
7861 gfc_conv_variable (se
, expr
);
7865 se
->expr
= null_pointer_node
;
7868 case EXPR_SUBSTRING
:
7869 gfc_conv_substring_expr (se
, expr
);
7872 case EXPR_STRUCTURE
:
7873 gfc_conv_structure (se
, expr
, 0);
7877 gfc_conv_array_constructor_expr (se
, expr
);
7886 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7887 of an assignment. */
7889 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7891 gfc_conv_expr (se
, expr
);
7892 /* All numeric lvalues should have empty post chains. If not we need to
7893 figure out a way of rewriting an lvalue so that it has no post chain. */
7894 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7897 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7898 numeric expressions. Used for scalar values where inserting cleanup code
7901 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7905 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7906 gfc_conv_expr (se
, expr
);
7909 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7910 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7912 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7916 /* Helper to translate an expression and convert it to a particular type. */
7918 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7920 gfc_conv_expr_val (se
, expr
);
7921 se
->expr
= convert (type
, se
->expr
);
7925 /* Converts an expression so that it can be passed by reference. Scalar
7929 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7935 if (ss
&& ss
->info
->expr
== expr
7936 && ss
->info
->type
== GFC_SS_REFERENCE
)
7938 /* Returns a reference to the scalar evaluated outside the loop
7940 gfc_conv_expr (se
, expr
);
7942 if (expr
->ts
.type
== BT_CHARACTER
7943 && expr
->expr_type
!= EXPR_FUNCTION
)
7944 gfc_conv_string_parameter (se
);
7946 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7951 if (expr
->ts
.type
== BT_CHARACTER
)
7953 gfc_conv_expr (se
, expr
);
7954 gfc_conv_string_parameter (se
);
7958 if (expr
->expr_type
== EXPR_VARIABLE
)
7960 se
->want_pointer
= 1;
7961 gfc_conv_expr (se
, expr
);
7964 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7965 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7966 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7972 if (expr
->expr_type
== EXPR_FUNCTION
7973 && ((expr
->value
.function
.esym
7974 && expr
->value
.function
.esym
->result
->attr
.pointer
7975 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7976 || (!expr
->value
.function
.esym
&& !expr
->ref
7977 && expr
->symtree
->n
.sym
->attr
.pointer
7978 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7980 se
->want_pointer
= 1;
7981 gfc_conv_expr (se
, expr
);
7982 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7983 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7988 gfc_conv_expr (se
, expr
);
7990 /* Create a temporary var to hold the value. */
7991 if (TREE_CONSTANT (se
->expr
))
7993 tree tmp
= se
->expr
;
7994 STRIP_TYPE_NOPS (tmp
);
7995 var
= build_decl (input_location
,
7996 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7997 DECL_INITIAL (var
) = tmp
;
7998 TREE_STATIC (var
) = 1;
8003 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8004 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8006 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8008 /* Take the address of that value. */
8009 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8013 /* Get the _len component for an unlimited polymorphic expression. */
8016 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8019 gfc_ref
*ref
= expr
->ref
;
8021 gfc_init_se (&se
, NULL
);
8022 while (ref
&& ref
->next
)
8024 gfc_add_len_component (expr
);
8025 gfc_conv_expr (&se
, expr
);
8026 gfc_add_block_to_block (block
, &se
.pre
);
8027 gcc_assert (se
.post
.head
== NULL_TREE
);
8030 gfc_free_ref_list (ref
->next
);
8035 gfc_free_ref_list (expr
->ref
);
8042 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8043 statement-list outside of the scalarizer-loop. When code is generated, that
8044 depends on the scalarized expression, it is added to RSE.PRE.
8045 Returns le's _vptr tree and when set the len expressions in to_lenp and
8046 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8050 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8051 gfc_expr
* re
, gfc_se
*rse
,
8052 tree
* to_lenp
, tree
* from_lenp
)
8055 gfc_expr
* vptr_expr
;
8056 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8057 bool set_vptr
= false, temp_rhs
= false;
8058 stmtblock_t
*pre
= block
;
8060 /* Create a temporary for complicated expressions. */
8061 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8062 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8064 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8066 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8071 /* Get the _vptr for the left-hand side expression. */
8072 gfc_init_se (&se
, NULL
);
8073 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8074 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8076 /* Care about _len for unlimited polymorphic entities. */
8077 if (UNLIMITED_POLY (vptr_expr
)
8078 || (vptr_expr
->ts
.type
== BT_DERIVED
8079 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8080 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8081 gfc_add_vptr_component (vptr_expr
);
8085 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8086 se
.want_pointer
= 1;
8087 gfc_conv_expr (&se
, vptr_expr
);
8088 gfc_free_expr (vptr_expr
);
8089 gfc_add_block_to_block (block
, &se
.pre
);
8090 gcc_assert (se
.post
.head
== NULL_TREE
);
8092 STRIP_NOPS (lhs_vptr
);
8094 /* Set the _vptr only when the left-hand side of the assignment is a
8098 /* Get the vptr from the rhs expression only, when it is variable.
8099 Functions are expected to be assigned to a temporary beforehand. */
8100 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8101 ? gfc_find_and_cut_at_last_class_ref (re
)
8103 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8105 if (to_len
!= NULL_TREE
)
8107 /* Get the _len information from the rhs. */
8108 if (UNLIMITED_POLY (vptr_expr
)
8109 || (vptr_expr
->ts
.type
== BT_DERIVED
8110 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8111 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8113 gfc_add_vptr_component (vptr_expr
);
8117 if (re
->expr_type
== EXPR_VARIABLE
8118 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8119 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8120 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8121 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8122 re
->symtree
->n
.sym
->backend_decl
))))
8125 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8126 re
->symtree
->n
.sym
->backend_decl
));
8128 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8129 re
->symtree
->n
.sym
->backend_decl
));
8131 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8134 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8135 if (UNLIMITED_POLY (re
))
8136 from_len
= gfc_class_len_get (rse
->expr
);
8138 else if (re
->expr_type
!= EXPR_NULL
)
8139 /* Only when rhs is non-NULL use its declared type for vptr
8141 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8143 /* When the rhs is NULL use the vtab of lhs' declared type. */
8144 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8149 gfc_init_se (&se
, NULL
);
8150 se
.want_pointer
= 1;
8151 gfc_conv_expr (&se
, vptr_expr
);
8152 gfc_free_expr (vptr_expr
);
8153 gfc_add_block_to_block (block
, &se
.pre
);
8154 gcc_assert (se
.post
.head
== NULL_TREE
);
8156 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8159 if (to_len
!= NULL_TREE
)
8161 /* The _len component needs to be set. Figure how to get the
8162 value of the right-hand side. */
8163 if (from_len
== NULL_TREE
)
8165 if (rse
->string_length
!= NULL_TREE
)
8166 from_len
= rse
->string_length
;
8167 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8169 from_len
= gfc_get_expr_charlen (re
);
8170 gfc_init_se (&se
, NULL
);
8171 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8172 gfc_add_block_to_block (block
, &se
.pre
);
8173 gcc_assert (se
.post
.head
== NULL_TREE
);
8174 from_len
= gfc_evaluate_now (se
.expr
, block
);
8177 from_len
= integer_zero_node
;
8179 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8184 /* Return the _len trees only, when requested. */
8188 *from_lenp
= from_len
;
8193 /* Assign tokens for pointer components. */
8196 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8199 symbol_attribute lhs_attr
, rhs_attr
;
8200 tree tmp
, lhs_tok
, rhs_tok
;
8201 /* Flag to indicated component refs on the rhs. */
8204 lhs_attr
= gfc_caf_attr (expr1
);
8205 if (expr2
->expr_type
!= EXPR_NULL
)
8207 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8208 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8210 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8211 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8214 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8218 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8219 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8222 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8224 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8225 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8228 else if (lhs_attr
.codimension
)
8230 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8231 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8232 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8233 lhs_tok
, null_pointer_node
);
8234 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8238 /* Indentify class valued proc_pointer assignments. */
8241 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8246 while (ref
&& ref
->next
)
8249 return ref
&& ref
->type
== REF_COMPONENT
8250 && ref
->u
.c
.component
->attr
.proc_pointer
8251 && expr2
->expr_type
== EXPR_VARIABLE
8252 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8256 /* Do everything that is needed for a CLASS function expr2. */
8259 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8260 gfc_expr
*expr1
, gfc_expr
*expr2
)
8262 tree expr1_vptr
= NULL_TREE
;
8265 gfc_conv_function_expr (rse
, expr2
);
8266 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8268 if (expr1
->ts
.type
!= BT_CLASS
)
8269 rse
->expr
= gfc_class_data_get (rse
->expr
);
8272 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8275 gfc_add_block_to_block (block
, &rse
->pre
);
8276 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8277 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8279 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8280 fold_convert (TREE_TYPE (expr1_vptr
),
8281 gfc_class_vptr_get (tmp
)));
8282 rse
->expr
= gfc_class_data_get (tmp
);
8290 gfc_trans_pointer_assign (gfc_code
* code
)
8292 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8296 /* Generate code for a pointer assignment. */
8299 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8306 tree expr1_vptr
= NULL_TREE
;
8307 bool scalar
, non_proc_pointer_assign
;
8310 gfc_start_block (&block
);
8312 gfc_init_se (&lse
, NULL
);
8314 /* Usually testing whether this is not a proc pointer assignment. */
8315 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8317 /* Check whether the expression is a scalar or not; we cannot use
8318 expr1->rank as it can be nonzero for proc pointers. */
8319 ss
= gfc_walk_expr (expr1
);
8320 scalar
= ss
== gfc_ss_terminator
;
8322 gfc_free_ss_chain (ss
);
8324 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8325 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8327 gfc_add_data_component (expr2
);
8328 /* The following is required as gfc_add_data_component doesn't
8329 update ts.type if there is a tailing REF_ARRAY. */
8330 expr2
->ts
.type
= BT_DERIVED
;
8335 /* Scalar pointers. */
8336 lse
.want_pointer
= 1;
8337 gfc_conv_expr (&lse
, expr1
);
8338 gfc_init_se (&rse
, NULL
);
8339 rse
.want_pointer
= 1;
8340 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8341 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8343 gfc_conv_expr (&rse
, expr2
);
8345 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8347 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8349 lse
.expr
= gfc_class_data_get (lse
.expr
);
8352 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8353 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8354 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8357 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8358 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8359 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8362 gfc_add_block_to_block (&block
, &lse
.pre
);
8363 gfc_add_block_to_block (&block
, &rse
.pre
);
8365 /* Check character lengths if character expression. The test is only
8366 really added if -fbounds-check is enabled. Exclude deferred
8367 character length lefthand sides. */
8368 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8369 && !expr1
->ts
.deferred
8370 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8371 && !gfc_is_proc_ptr_comp (expr1
))
8373 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8374 gcc_assert (lse
.string_length
&& rse
.string_length
);
8375 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8376 lse
.string_length
, rse
.string_length
,
8380 /* The assignment to an deferred character length sets the string
8381 length to that of the rhs. */
8382 if (expr1
->ts
.deferred
)
8384 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8385 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
8386 else if (lse
.string_length
!= NULL
)
8387 gfc_add_modify (&block
, lse
.string_length
,
8388 build_int_cst (gfc_charlen_type_node
, 0));
8391 gfc_add_modify (&block
, lse
.expr
,
8392 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8394 /* Also set the tokens for pointer components in derived typed
8396 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8397 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8399 gfc_add_block_to_block (&block
, &rse
.post
);
8400 gfc_add_block_to_block (&block
, &lse
.post
);
8407 tree strlen_rhs
= NULL_TREE
;
8409 /* Array pointer. Find the last reference on the LHS and if it is an
8410 array section ref, we're dealing with bounds remapping. In this case,
8411 set it to AR_FULL so that gfc_conv_expr_descriptor does
8412 not see it and process the bounds remapping afterwards explicitly. */
8413 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8414 if (!remap
->next
&& remap
->type
== REF_ARRAY
8415 && remap
->u
.ar
.type
== AR_SECTION
)
8417 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8419 gfc_init_se (&lse
, NULL
);
8421 lse
.descriptor_only
= 1;
8422 gfc_conv_expr_descriptor (&lse
, expr1
);
8423 strlen_lhs
= lse
.string_length
;
8426 if (expr2
->expr_type
== EXPR_NULL
)
8428 /* Just set the data pointer to null. */
8429 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8431 else if (rank_remap
)
8433 /* If we are rank-remapping, just get the RHS's descriptor and
8434 process this later on. */
8435 gfc_init_se (&rse
, NULL
);
8436 rse
.direct_byref
= 1;
8437 rse
.byref_noassign
= 1;
8439 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8440 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8442 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8444 tree bound
[GFC_MAX_DIMENSIONS
];
8447 for (i
= 0; i
< expr2
->rank
; i
++)
8448 bound
[i
] = NULL_TREE
;
8449 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8450 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8452 GFC_ARRAY_POINTER_CONT
, false);
8453 tmp
= gfc_create_var (tmp
, "ptrtemp");
8454 rse
.descriptor_only
= 0;
8456 rse
.direct_byref
= 1;
8457 gfc_conv_expr_descriptor (&rse
, expr2
);
8458 strlen_rhs
= rse
.string_length
;
8463 gfc_conv_expr_descriptor (&rse
, expr2
);
8464 strlen_rhs
= rse
.string_length
;
8465 if (expr1
->ts
.type
== BT_CLASS
)
8466 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8471 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8473 /* Assign directly to the LHS's descriptor. */
8474 lse
.descriptor_only
= 0;
8475 lse
.direct_byref
= 1;
8476 gfc_conv_expr_descriptor (&lse
, expr2
);
8477 strlen_rhs
= lse
.string_length
;
8479 if (expr1
->ts
.type
== BT_CLASS
)
8481 rse
.expr
= NULL_TREE
;
8482 rse
.string_length
= NULL_TREE
;
8483 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8489 /* If the target is not a whole array, use the target array
8490 reference for remap. */
8491 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8492 if (remap
->type
== REF_ARRAY
8493 && remap
->u
.ar
.type
== AR_FULL
8498 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8500 gfc_init_se (&rse
, NULL
);
8501 rse
.want_pointer
= 1;
8502 gfc_conv_function_expr (&rse
, expr2
);
8503 if (expr1
->ts
.type
!= BT_CLASS
)
8505 rse
.expr
= gfc_class_data_get (rse
.expr
);
8506 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8507 /* Set the lhs span. */
8508 tmp
= TREE_TYPE (rse
.expr
);
8509 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8510 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8511 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8515 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8518 gfc_add_block_to_block (&block
, &rse
.pre
);
8519 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8520 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8522 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8523 fold_convert (TREE_TYPE (expr1_vptr
),
8524 gfc_class_vptr_get (tmp
)));
8525 rse
.expr
= gfc_class_data_get (tmp
);
8526 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8531 /* Assign to a temporary descriptor and then copy that
8532 temporary to the pointer. */
8533 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8534 lse
.descriptor_only
= 0;
8536 lse
.direct_byref
= 1;
8537 gfc_conv_expr_descriptor (&lse
, expr2
);
8538 strlen_rhs
= lse
.string_length
;
8539 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8542 gfc_add_block_to_block (&block
, &lse
.pre
);
8544 gfc_add_block_to_block (&block
, &rse
.pre
);
8546 /* If we do bounds remapping, update LHS descriptor accordingly. */
8550 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8554 /* Do rank remapping. We already have the RHS's descriptor
8555 converted in rse and now have to build the correct LHS
8556 descriptor for it. */
8558 tree dtype
, data
, span
;
8560 tree lbound
, ubound
;
8563 dtype
= gfc_conv_descriptor_dtype (desc
);
8564 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8565 gfc_add_modify (&block
, dtype
, tmp
);
8567 /* Copy data pointer. */
8568 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8569 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8571 /* Copy the span. */
8572 if (TREE_CODE (rse
.expr
) == VAR_DECL
8573 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8574 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8577 tmp
= TREE_TYPE (rse
.expr
);
8578 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8579 span
= fold_convert (gfc_array_index_type
, tmp
);
8581 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8583 /* Copy offset but adjust it such that it would correspond
8584 to a lbound of zero. */
8585 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8586 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8588 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8590 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8592 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8593 gfc_array_index_type
, stride
, lbound
);
8594 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8595 gfc_array_index_type
, offs
, tmp
);
8597 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8599 /* Set the bounds as declared for the LHS and calculate strides as
8600 well as another offset update accordingly. */
8601 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8603 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8608 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8610 /* Convert declared bounds. */
8611 gfc_init_se (&lower_se
, NULL
);
8612 gfc_init_se (&upper_se
, NULL
);
8613 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8614 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8616 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8617 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8619 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8620 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8622 lbound
= gfc_evaluate_now (lbound
, &block
);
8623 ubound
= gfc_evaluate_now (ubound
, &block
);
8625 gfc_add_block_to_block (&block
, &lower_se
.post
);
8626 gfc_add_block_to_block (&block
, &upper_se
.post
);
8628 /* Set bounds in descriptor. */
8629 gfc_conv_descriptor_lbound_set (&block
, desc
,
8630 gfc_rank_cst
[dim
], lbound
);
8631 gfc_conv_descriptor_ubound_set (&block
, desc
,
8632 gfc_rank_cst
[dim
], ubound
);
8635 stride
= gfc_evaluate_now (stride
, &block
);
8636 gfc_conv_descriptor_stride_set (&block
, desc
,
8637 gfc_rank_cst
[dim
], stride
);
8639 /* Update offset. */
8640 offs
= gfc_conv_descriptor_offset_get (desc
);
8641 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8642 gfc_array_index_type
, lbound
, stride
);
8643 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8644 gfc_array_index_type
, offs
, tmp
);
8645 offs
= gfc_evaluate_now (offs
, &block
);
8646 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8648 /* Update stride. */
8649 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8650 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8651 gfc_array_index_type
, stride
, tmp
);
8656 /* Bounds remapping. Just shift the lower bounds. */
8658 gcc_assert (expr1
->rank
== expr2
->rank
);
8660 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8664 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8665 gfc_init_se (&lbound_se
, NULL
);
8666 if (remap
->u
.ar
.start
[dim
])
8668 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8669 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8672 /* This remap arises from a target that is not a whole
8673 array. The start expressions will be NULL but we need
8674 the lbounds to be one. */
8675 lbound_se
.expr
= gfc_index_one_node
;
8676 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8677 dim
, lbound_se
.expr
);
8678 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8683 /* Check string lengths if applicable. The check is only really added
8684 to the output code if -fbounds-check is enabled. */
8685 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8687 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8688 gcc_assert (strlen_lhs
&& strlen_rhs
);
8689 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8690 strlen_lhs
, strlen_rhs
, &block
);
8693 /* If rank remapping was done, check with -fcheck=bounds that
8694 the target is at least as large as the pointer. */
8695 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8701 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8702 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8704 lsize
= gfc_evaluate_now (lsize
, &block
);
8705 rsize
= gfc_evaluate_now (rsize
, &block
);
8706 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
8709 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8710 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8714 gfc_add_block_to_block (&block
, &lse
.post
);
8716 gfc_add_block_to_block (&block
, &rse
.post
);
8719 return gfc_finish_block (&block
);
8723 /* Makes sure se is suitable for passing as a function string parameter. */
8724 /* TODO: Need to check all callers of this function. It may be abused. */
8727 gfc_conv_string_parameter (gfc_se
* se
)
8731 if (TREE_CODE (se
->expr
) == STRING_CST
)
8733 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8734 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8738 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8740 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8742 type
= TREE_TYPE (se
->expr
);
8743 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8747 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8749 type
= build_pointer_type (type
);
8750 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8754 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8758 /* Generate code for assignment of scalar variables. Includes character
8759 strings and derived types with allocatable components.
8760 If you know that the LHS has no allocations, set dealloc to false.
8762 DEEP_COPY has no effect if the typespec TS is not a derived type with
8763 allocatable components. Otherwise, if it is set, an explicit copy of each
8764 allocatable component is made. This is necessary as a simple copy of the
8765 whole object would copy array descriptors as is, so that the lhs's
8766 allocatable components would point to the rhs's after the assignment.
8767 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8768 necessary if the rhs is a non-pointer function, as the allocatable components
8769 are not accessible by other means than the function's result after the
8770 function has returned. It is even more subtle when temporaries are involved,
8771 as the two following examples show:
8772 1. When we evaluate an array constructor, a temporary is created. Thus
8773 there is theoretically no alias possible. However, no deep copy is
8774 made for this temporary, so that if the constructor is made of one or
8775 more variable with allocatable components, those components still point
8776 to the variable's: DEEP_COPY should be set for the assignment from the
8777 temporary to the lhs in that case.
8778 2. When assigning a scalar to an array, we evaluate the scalar value out
8779 of the loop, store it into a temporary variable, and assign from that.
8780 In that case, deep copying when assigning to the temporary would be a
8781 waste of resources; however deep copies should happen when assigning from
8782 the temporary to each array element: again DEEP_COPY should be set for
8783 the assignment from the temporary to the lhs. */
8786 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8787 bool deep_copy
, bool dealloc
, bool in_coarray
)
8793 gfc_init_block (&block
);
8795 if (ts
.type
== BT_CHARACTER
)
8800 if (lse
->string_length
!= NULL_TREE
)
8802 gfc_conv_string_parameter (lse
);
8803 gfc_add_block_to_block (&block
, &lse
->pre
);
8804 llen
= lse
->string_length
;
8807 if (rse
->string_length
!= NULL_TREE
)
8809 gfc_conv_string_parameter (rse
);
8810 gfc_add_block_to_block (&block
, &rse
->pre
);
8811 rlen
= rse
->string_length
;
8814 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8815 rse
->expr
, ts
.kind
);
8817 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8819 tree tmp_var
= NULL_TREE
;
8822 /* Are the rhs and the lhs the same? */
8825 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8826 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8827 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8828 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8831 /* Deallocate the lhs allocated components as long as it is not
8832 the same as the rhs. This must be done following the assignment
8833 to prevent deallocating data that could be used in the rhs
8837 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8838 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8840 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8842 gfc_add_expr_to_block (&lse
->post
, tmp
);
8845 gfc_add_block_to_block (&block
, &rse
->pre
);
8846 gfc_add_block_to_block (&block
, &lse
->pre
);
8848 gfc_add_modify (&block
, lse
->expr
,
8849 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8851 /* Restore pointer address of coarray components. */
8852 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8854 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8855 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8857 gfc_add_expr_to_block (&block
, tmp
);
8860 /* Do a deep copy if the rhs is a variable, if it is not the
8864 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8865 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
8866 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
8868 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8870 gfc_add_expr_to_block (&block
, tmp
);
8873 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8875 gfc_add_block_to_block (&block
, &lse
->pre
);
8876 gfc_add_block_to_block (&block
, &rse
->pre
);
8877 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8878 TREE_TYPE (lse
->expr
), rse
->expr
);
8879 gfc_add_modify (&block
, lse
->expr
, tmp
);
8883 gfc_add_block_to_block (&block
, &lse
->pre
);
8884 gfc_add_block_to_block (&block
, &rse
->pre
);
8886 gfc_add_modify (&block
, lse
->expr
,
8887 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8890 gfc_add_block_to_block (&block
, &lse
->post
);
8891 gfc_add_block_to_block (&block
, &rse
->post
);
8893 return gfc_finish_block (&block
);
8897 /* There are quite a lot of restrictions on the optimisation in using an
8898 array function assign without a temporary. */
8901 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8904 bool seen_array_ref
;
8906 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8908 /* Play it safe with class functions assigned to a derived type. */
8909 if (gfc_is_class_array_function (expr2
)
8910 && expr1
->ts
.type
== BT_DERIVED
)
8913 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8914 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8917 /* Elemental functions are scalarized so that they don't need a
8918 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8919 they would need special treatment in gfc_trans_arrayfunc_assign. */
8920 if (expr2
->value
.function
.esym
!= NULL
8921 && expr2
->value
.function
.esym
->attr
.elemental
)
8924 /* Need a temporary if rhs is not FULL or a contiguous section. */
8925 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8928 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8929 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8932 /* Functions returning pointers or allocatables need temporaries. */
8933 c
= expr2
->value
.function
.esym
8934 ? (expr2
->value
.function
.esym
->attr
.pointer
8935 || expr2
->value
.function
.esym
->attr
.allocatable
)
8936 : (expr2
->symtree
->n
.sym
->attr
.pointer
8937 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8941 /* Character array functions need temporaries unless the
8942 character lengths are the same. */
8943 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8945 if (expr1
->ts
.u
.cl
->length
== NULL
8946 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8949 if (expr2
->ts
.u
.cl
->length
== NULL
8950 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8953 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8954 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8958 /* Check that no LHS component references appear during an array
8959 reference. This is needed because we do not have the means to
8960 span any arbitrary stride with an array descriptor. This check
8961 is not needed for the rhs because the function result has to be
8963 seen_array_ref
= false;
8964 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8966 if (ref
->type
== REF_ARRAY
)
8967 seen_array_ref
= true;
8968 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8972 /* Check for a dependency. */
8973 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8974 expr2
->value
.function
.esym
,
8975 expr2
->value
.function
.actual
,
8979 /* If we have reached here with an intrinsic function, we do not
8980 need a temporary except in the particular case that reallocation
8981 on assignment is active and the lhs is allocatable and a target. */
8982 if (expr2
->value
.function
.isym
)
8983 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8985 /* If the LHS is a dummy, we need a temporary if it is not
8987 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8990 /* If the lhs has been host_associated, is in common, a pointer or is
8991 a target and the function is not using a RESULT variable, aliasing
8992 can occur and a temporary is needed. */
8993 if ((sym
->attr
.host_assoc
8994 || sym
->attr
.in_common
8995 || sym
->attr
.pointer
8996 || sym
->attr
.cray_pointee
8997 || sym
->attr
.target
)
8998 && expr2
->symtree
!= NULL
8999 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9002 /* A PURE function can unconditionally be called without a temporary. */
9003 if (expr2
->value
.function
.esym
!= NULL
9004 && expr2
->value
.function
.esym
->attr
.pure
)
9007 /* Implicit_pure functions are those which could legally be declared
9009 if (expr2
->value
.function
.esym
!= NULL
9010 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9013 if (!sym
->attr
.use_assoc
9014 && !sym
->attr
.in_common
9015 && !sym
->attr
.pointer
9016 && !sym
->attr
.target
9017 && !sym
->attr
.cray_pointee
9018 && expr2
->value
.function
.esym
)
9020 /* A temporary is not needed if the function is not contained and
9021 the variable is local or host associated and not a pointer or
9023 if (!expr2
->value
.function
.esym
->attr
.contained
)
9026 /* A temporary is not needed if the lhs has never been host
9027 associated and the procedure is contained. */
9028 else if (!sym
->attr
.host_assoc
)
9031 /* A temporary is not needed if the variable is local and not
9032 a pointer, a target or a result. */
9034 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9038 /* Default to temporary use. */
9043 /* Provide the loop info so that the lhs descriptor can be built for
9044 reallocatable assignments from extrinsic function calls. */
9047 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9050 /* Signal that the function call should not be made by
9051 gfc_conv_loop_setup. */
9052 se
->ss
->is_alloc_lhs
= 1;
9053 gfc_init_loopinfo (loop
);
9054 gfc_add_ss_to_loop (loop
, *ss
);
9055 gfc_add_ss_to_loop (loop
, se
->ss
);
9056 gfc_conv_ss_startstride (loop
);
9057 gfc_conv_loop_setup (loop
, where
);
9058 gfc_copy_loopinfo_to_se (se
, loop
);
9059 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9060 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9061 se
->ss
->is_alloc_lhs
= 0;
9065 /* For assignment to a reallocatable lhs from intrinsic functions,
9066 replace the se.expr (ie. the result) with a temporary descriptor.
9067 Null the data field so that the library allocates space for the
9068 result. Free the data of the original descriptor after the function,
9069 in case it appears in an argument expression and transfer the
9070 result to the original descriptor. */
9073 fcncall_realloc_result (gfc_se
*se
, int rank
)
9082 /* Use the allocation done by the library. Substitute the lhs
9083 descriptor with a copy, whose data field is nulled.*/
9084 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9085 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9086 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9088 /* Unallocated, the descriptor does not have a dtype. */
9089 tmp
= gfc_conv_descriptor_dtype (desc
);
9090 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9092 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9093 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9094 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9096 /* Free the lhs after the function call and copy the result data to
9097 the lhs descriptor. */
9098 tmp
= gfc_conv_descriptor_data_get (desc
);
9099 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9100 logical_type_node
, tmp
,
9101 build_int_cst (TREE_TYPE (tmp
), 0));
9102 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9103 tmp
= gfc_call_free (tmp
);
9104 gfc_add_expr_to_block (&se
->post
, tmp
);
9106 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9107 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9109 /* Check that the shapes are the same between lhs and expression. */
9110 for (n
= 0 ; n
< rank
; n
++)
9113 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9114 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9115 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9116 gfc_array_index_type
, tmp
, tmp1
);
9117 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9118 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9119 gfc_array_index_type
, tmp
, tmp1
);
9120 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9121 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9122 gfc_array_index_type
, tmp
, tmp1
);
9123 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9124 logical_type_node
, tmp
,
9125 gfc_index_zero_node
);
9126 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9127 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9128 logical_type_node
, tmp
,
9132 /* 'zero_cond' being true is equal to lhs not being allocated or the
9133 shapes being different. */
9134 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9136 /* Now reset the bounds returned from the function call to bounds based
9137 on the lhs lbounds, except where the lhs is not allocated or the shapes
9138 of 'variable and 'expr' are different. Set the offset accordingly. */
9139 offset
= gfc_index_zero_node
;
9140 for (n
= 0 ; n
< rank
; n
++)
9144 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9145 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9146 gfc_array_index_type
, zero_cond
,
9147 gfc_index_one_node
, lbound
);
9148 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9150 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9151 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9152 gfc_array_index_type
, tmp
, lbound
);
9153 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9154 gfc_rank_cst
[n
], lbound
);
9155 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9156 gfc_rank_cst
[n
], tmp
);
9158 /* Set stride and accumulate the offset. */
9159 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9160 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9161 gfc_rank_cst
[n
], tmp
);
9162 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9163 gfc_array_index_type
, lbound
, tmp
);
9164 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9165 gfc_array_index_type
, offset
, tmp
);
9166 offset
= gfc_evaluate_now (offset
, &se
->post
);
9169 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9174 /* Try to translate array(:) = func (...), where func is a transformational
9175 array function, without using a temporary. Returns NULL if this isn't the
9179 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9183 gfc_component
*comp
= NULL
;
9186 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9189 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9191 comp
= gfc_get_proc_ptr_comp (expr2
);
9192 gcc_assert (expr2
->value
.function
.isym
9193 || (comp
&& comp
->attr
.dimension
)
9194 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9195 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
9197 gfc_init_se (&se
, NULL
);
9198 gfc_start_block (&se
.pre
);
9199 se
.want_pointer
= 1;
9201 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9203 if (expr1
->ts
.type
== BT_DERIVED
9204 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9207 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9209 gfc_add_expr_to_block (&se
.pre
, tmp
);
9212 se
.direct_byref
= 1;
9213 se
.ss
= gfc_walk_expr (expr2
);
9214 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9216 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9217 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9218 Clearly, this cannot be done for an allocatable function result, since
9219 the shape of the result is unknown and, in any case, the function must
9220 correctly take care of the reallocation internally. For intrinsic
9221 calls, the array data is freed and the library takes care of allocation.
9222 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9224 if (flag_realloc_lhs
9225 && gfc_is_reallocatable_lhs (expr1
)
9226 && !gfc_expr_attr (expr1
).codimension
9227 && !gfc_is_coindexed (expr1
)
9228 && !(expr2
->value
.function
.esym
9229 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9231 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9233 if (!expr2
->value
.function
.isym
)
9235 ss
= gfc_walk_expr (expr1
);
9236 gcc_assert (ss
!= gfc_ss_terminator
);
9238 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9239 ss
->is_alloc_lhs
= 1;
9242 fcncall_realloc_result (&se
, expr1
->rank
);
9245 gfc_conv_function_expr (&se
, expr2
);
9246 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9249 gfc_cleanup_loop (&loop
);
9251 gfc_free_ss_chain (se
.ss
);
9253 return gfc_finish_block (&se
.pre
);
9257 /* Try to efficiently translate array(:) = 0. Return NULL if this
9261 gfc_trans_zero_assign (gfc_expr
* expr
)
9263 tree dest
, len
, type
;
9267 sym
= expr
->symtree
->n
.sym
;
9268 dest
= gfc_get_symbol_decl (sym
);
9270 type
= TREE_TYPE (dest
);
9271 if (POINTER_TYPE_P (type
))
9272 type
= TREE_TYPE (type
);
9273 if (!GFC_ARRAY_TYPE_P (type
))
9276 /* Determine the length of the array. */
9277 len
= GFC_TYPE_ARRAY_SIZE (type
);
9278 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9281 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9282 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9283 fold_convert (gfc_array_index_type
, tmp
));
9285 /* If we are zeroing a local array avoid taking its address by emitting
9287 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9288 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9289 dest
, build_constructor (TREE_TYPE (dest
),
9292 /* Convert arguments to the correct types. */
9293 dest
= fold_convert (pvoid_type_node
, dest
);
9294 len
= fold_convert (size_type_node
, len
);
9296 /* Construct call to __builtin_memset. */
9297 tmp
= build_call_expr_loc (input_location
,
9298 builtin_decl_explicit (BUILT_IN_MEMSET
),
9299 3, dest
, integer_zero_node
, len
);
9300 return fold_convert (void_type_node
, tmp
);
9304 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9305 that constructs the call to __builtin_memcpy. */
9308 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9312 /* Convert arguments to the correct types. */
9313 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9314 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9316 dst
= fold_convert (pvoid_type_node
, dst
);
9318 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9319 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9321 src
= fold_convert (pvoid_type_node
, src
);
9323 len
= fold_convert (size_type_node
, len
);
9325 /* Construct call to __builtin_memcpy. */
9326 tmp
= build_call_expr_loc (input_location
,
9327 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9329 return fold_convert (void_type_node
, tmp
);
9333 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9334 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9335 source/rhs, both are gfc_full_array_ref_p which have been checked for
9339 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9341 tree dst
, dlen
, dtype
;
9342 tree src
, slen
, stype
;
9345 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9346 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9348 dtype
= TREE_TYPE (dst
);
9349 if (POINTER_TYPE_P (dtype
))
9350 dtype
= TREE_TYPE (dtype
);
9351 stype
= TREE_TYPE (src
);
9352 if (POINTER_TYPE_P (stype
))
9353 stype
= TREE_TYPE (stype
);
9355 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9358 /* Determine the lengths of the arrays. */
9359 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9360 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9362 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9363 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9364 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9366 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9367 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9369 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9370 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9371 slen
, fold_convert (gfc_array_index_type
, tmp
));
9373 /* Sanity check that they are the same. This should always be
9374 the case, as we should already have checked for conformance. */
9375 if (!tree_int_cst_equal (slen
, dlen
))
9378 return gfc_build_memcpy_call (dst
, src
, dlen
);
9382 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9383 this can't be done. EXPR1 is the destination/lhs for which
9384 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9387 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9389 unsigned HOST_WIDE_INT nelem
;
9395 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9399 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9400 dtype
= TREE_TYPE (dst
);
9401 if (POINTER_TYPE_P (dtype
))
9402 dtype
= TREE_TYPE (dtype
);
9403 if (!GFC_ARRAY_TYPE_P (dtype
))
9406 /* Determine the lengths of the array. */
9407 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9408 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9411 /* Confirm that the constructor is the same size. */
9412 if (compare_tree_int (len
, nelem
) != 0)
9415 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9416 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9417 fold_convert (gfc_array_index_type
, tmp
));
9419 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9420 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9422 stype
= TREE_TYPE (src
);
9423 if (POINTER_TYPE_P (stype
))
9424 stype
= TREE_TYPE (stype
);
9426 return gfc_build_memcpy_call (dst
, src
, len
);
9430 /* Tells whether the expression is to be treated as a variable reference. */
9433 gfc_expr_is_variable (gfc_expr
*expr
)
9436 gfc_component
*comp
;
9437 gfc_symbol
*func_ifc
;
9439 if (expr
->expr_type
== EXPR_VARIABLE
)
9442 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9445 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9446 return gfc_expr_is_variable (arg
);
9449 /* A data-pointer-returning function should be considered as a variable
9451 if (expr
->expr_type
== EXPR_FUNCTION
9452 && expr
->ref
== NULL
)
9454 if (expr
->value
.function
.isym
!= NULL
)
9457 if (expr
->value
.function
.esym
!= NULL
)
9459 func_ifc
= expr
->value
.function
.esym
;
9464 gcc_assert (expr
->symtree
);
9465 func_ifc
= expr
->symtree
->n
.sym
;
9472 comp
= gfc_get_proc_ptr_comp (expr
);
9473 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9476 func_ifc
= comp
->ts
.interface
;
9480 if (expr
->expr_type
== EXPR_COMPCALL
)
9482 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9483 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9490 gcc_assert (func_ifc
->attr
.function
9491 && func_ifc
->result
!= NULL
);
9492 return func_ifc
->result
->attr
.pointer
;
9496 /* Is the lhs OK for automatic reallocation? */
9499 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9503 /* An allocatable variable with no reference. */
9504 if (expr
->symtree
->n
.sym
->attr
.allocatable
9508 /* All that can be left are allocatable components. However, we do
9509 not check for allocatable components here because the expression
9510 could be an allocatable component of a pointer component. */
9511 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9512 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9515 /* Find an allocatable component ref last. */
9516 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9517 if (ref
->type
== REF_COMPONENT
9519 && ref
->u
.c
.component
->attr
.allocatable
)
9526 /* Allocate or reallocate scalar lhs, as necessary. */
9529 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9544 if (!expr1
|| expr1
->rank
)
9547 if (!expr2
|| expr2
->rank
)
9550 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9551 if (ref
->type
== REF_SUBSTRING
)
9554 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9556 /* Since this is a scalar lhs, we can afford to do this. That is,
9557 there is no risk of side effects being repeated. */
9558 gfc_init_se (&lse
, NULL
);
9559 lse
.want_pointer
= 1;
9560 gfc_conv_expr (&lse
, expr1
);
9562 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9563 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9565 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9566 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9567 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9569 tmp
= build3_v (COND_EXPR
, cond
,
9570 build1_v (GOTO_EXPR
, jump_label1
),
9571 build_empty_stmt (input_location
));
9572 gfc_add_expr_to_block (block
, tmp
);
9574 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9576 /* Use the rhs string length and the lhs element size. */
9577 size
= string_length
;
9578 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9579 tmp
= TYPE_SIZE_UNIT (tmp
);
9580 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9581 TREE_TYPE (tmp
), tmp
,
9582 fold_convert (TREE_TYPE (tmp
), size
));
9586 /* Otherwise use the length in bytes of the rhs. */
9587 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9588 size_in_bytes
= size
;
9591 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9592 size_in_bytes
, size_one_node
);
9594 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9596 tree caf_decl
, token
;
9598 symbol_attribute attr
;
9600 gfc_clear_attr (&attr
);
9601 gfc_init_se (&caf_se
, NULL
);
9603 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9604 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9606 gfc_add_block_to_block (block
, &caf_se
.pre
);
9607 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9608 gfc_build_addr_expr (NULL_TREE
, token
),
9609 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9612 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9614 tmp
= build_call_expr_loc (input_location
,
9615 builtin_decl_explicit (BUILT_IN_CALLOC
),
9616 2, build_one_cst (size_type_node
),
9618 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9619 gfc_add_modify (block
, lse
.expr
, tmp
);
9623 tmp
= build_call_expr_loc (input_location
,
9624 builtin_decl_explicit (BUILT_IN_MALLOC
),
9626 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9627 gfc_add_modify (block
, lse
.expr
, tmp
);
9630 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9632 /* Deferred characters need checking for lhs and rhs string
9633 length. Other deferred parameter variables will have to
9635 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9636 gfc_add_expr_to_block (block
, tmp
);
9638 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9639 gfc_add_expr_to_block (block
, tmp
);
9641 /* For a deferred length character, reallocate if lengths of lhs and
9642 rhs are different. */
9643 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9645 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9646 lse
.string_length
, size
);
9647 /* Jump past the realloc if the lengths are the same. */
9648 tmp
= build3_v (COND_EXPR
, cond
,
9649 build1_v (GOTO_EXPR
, jump_label2
),
9650 build_empty_stmt (input_location
));
9651 gfc_add_expr_to_block (block
, tmp
);
9652 tmp
= build_call_expr_loc (input_location
,
9653 builtin_decl_explicit (BUILT_IN_REALLOC
),
9654 2, fold_convert (pvoid_type_node
, lse
.expr
),
9656 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9657 gfc_add_modify (block
, lse
.expr
, tmp
);
9658 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9659 gfc_add_expr_to_block (block
, tmp
);
9661 /* Update the lhs character length. */
9662 size
= string_length
;
9663 gfc_add_modify (block
, lse
.string_length
, size
);
9667 /* Check for assignments of the type
9671 to make sure we do not check for reallocation unneccessarily. */
9675 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9677 gfc_actual_arglist
*a
;
9680 switch (expr2
->expr_type
)
9683 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9686 if (expr2
->value
.function
.esym
9687 && expr2
->value
.function
.esym
->attr
.elemental
)
9689 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9692 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9697 else if (expr2
->value
.function
.isym
9698 && expr2
->value
.function
.isym
->elemental
)
9700 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9703 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9712 switch (expr2
->value
.op
.op
)
9715 case INTRINSIC_UPLUS
:
9716 case INTRINSIC_UMINUS
:
9717 case INTRINSIC_PARENTHESES
:
9718 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9720 case INTRINSIC_PLUS
:
9721 case INTRINSIC_MINUS
:
9722 case INTRINSIC_TIMES
:
9723 case INTRINSIC_DIVIDE
:
9724 case INTRINSIC_POWER
:
9728 case INTRINSIC_NEQV
:
9735 case INTRINSIC_EQ_OS
:
9736 case INTRINSIC_NE_OS
:
9737 case INTRINSIC_GT_OS
:
9738 case INTRINSIC_GE_OS
:
9739 case INTRINSIC_LT_OS
:
9740 case INTRINSIC_LE_OS
:
9742 e1
= expr2
->value
.op
.op1
;
9743 e2
= expr2
->value
.op
.op2
;
9745 if (e1
->rank
== 0 && e2
->rank
> 0)
9746 return is_runtime_conformable (expr1
, e2
);
9747 else if (e1
->rank
> 0 && e2
->rank
== 0)
9748 return is_runtime_conformable (expr1
, e1
);
9749 else if (e1
->rank
> 0 && e2
->rank
> 0)
9750 return is_runtime_conformable (expr1
, e1
)
9751 && is_runtime_conformable (expr1
, e2
);
9769 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9770 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
9773 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
9774 vec
<tree
, va_gc
> *args
= NULL
;
9776 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9779 /* Generate allocation of the lhs. */
9785 tmp
= gfc_vptr_size_get (vptr
);
9786 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9787 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9788 gfc_init_block (&alloc
);
9789 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
9790 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9791 logical_type_node
, class_han
,
9792 build_int_cst (prvoid_type_node
, 0));
9793 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
9795 PRED_FORTRAN_FAIL_ALLOC
),
9796 gfc_finish_block (&alloc
),
9797 build_empty_stmt (input_location
));
9798 gfc_add_expr_to_block (&lse
->pre
, tmp
);
9801 fcn
= gfc_vptr_copy_get (vptr
);
9803 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9804 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9807 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9808 || INDIRECT_REF_P (tmp
)
9809 || (rhs
->ts
.type
== BT_DERIVED
9810 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9811 && !rhs
->ts
.u
.derived
->attr
.pointer
9812 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9813 || (UNLIMITED_POLY (rhs
)
9814 && !CLASS_DATA (rhs
)->attr
.pointer
9815 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9816 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9818 vec_safe_push (args
, tmp
);
9819 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9820 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9821 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9822 || INDIRECT_REF_P (tmp
)
9823 || (lhs
->ts
.type
== BT_DERIVED
9824 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9825 && !lhs
->ts
.u
.derived
->attr
.pointer
9826 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9827 || (UNLIMITED_POLY (lhs
)
9828 && !CLASS_DATA (lhs
)->attr
.pointer
9829 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9830 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9832 vec_safe_push (args
, tmp
);
9834 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9836 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9839 vec_safe_push (args
, from_len
);
9840 vec_safe_push (args
, to_len
);
9841 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9843 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9844 logical_type_node
, from_len
,
9846 return fold_build3_loc (input_location
, COND_EXPR
,
9847 void_type_node
, tmp
,
9855 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9856 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9858 gfc_init_block (&tblock
);
9859 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9860 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9861 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9862 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9863 /* When coming from a ptr_copy lhs and rhs are swapped. */
9864 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9865 fold_convert (TREE_TYPE (rhst
), tmp
));
9866 return gfc_finish_block (&tblock
);
9870 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9871 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9872 init_flag indicates initialization expressions and dealloc that no
9873 deallocate prior assignment is needed (if in doubt, set true).
9874 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9875 routine instead of a pointer assignment. Alias resolution is only done,
9876 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9877 where it is known, that newly allocated memory on the lhs can never be
9878 an alias of the rhs. */
9881 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9882 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9887 gfc_ss
*lss_section
;
9894 bool scalar_to_array
;
9897 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
9898 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9899 bool is_poly_assign
;
9901 /* Assignment of the form lhs = rhs. */
9902 gfc_start_block (&block
);
9904 gfc_init_se (&lse
, NULL
);
9905 gfc_init_se (&rse
, NULL
);
9908 lss
= gfc_walk_expr (expr1
);
9909 if (gfc_is_reallocatable_lhs (expr1
)
9910 && !(expr2
->expr_type
== EXPR_FUNCTION
9911 && expr2
->value
.function
.isym
!= NULL
))
9912 lss
->is_alloc_lhs
= 1;
9915 if ((expr1
->ts
.type
== BT_DERIVED
)
9916 && (gfc_is_class_array_function (expr2
)
9917 || gfc_is_alloc_class_scalar_function (expr2
)))
9918 expr2
->must_finalize
= 1;
9920 /* Checking whether a class assignment is desired is quite complicated and
9921 needed at two locations, so do it once only before the information is
9923 lhs_attr
= gfc_expr_attr (expr1
);
9924 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
9925 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9926 && (expr1
->ts
.type
== BT_CLASS
9927 || gfc_is_class_array_ref (expr1
, NULL
)
9928 || gfc_is_class_scalar_expr (expr1
)
9929 || gfc_is_class_array_ref (expr2
, NULL
)
9930 || gfc_is_class_scalar_expr (expr2
));
9933 /* Only analyze the expressions for coarray properties, when in coarray-lib
9935 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9937 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
9938 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
9941 if (lss
!= gfc_ss_terminator
)
9943 /* The assignment needs scalarization. */
9946 /* Find a non-scalar SS from the lhs. */
9947 while (lss_section
!= gfc_ss_terminator
9948 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9949 lss_section
= lss_section
->next
;
9951 gcc_assert (lss_section
!= gfc_ss_terminator
);
9953 /* Initialize the scalarizer. */
9954 gfc_init_loopinfo (&loop
);
9957 rss
= gfc_walk_expr (expr2
);
9958 if (rss
== gfc_ss_terminator
)
9959 /* The rhs is scalar. Add a ss for the expression. */
9960 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9961 /* When doing a class assign, then the handle to the rhs needs to be a
9962 pointer to allow for polymorphism. */
9963 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
9964 rss
->info
->type
= GFC_SS_REFERENCE
;
9966 /* Associate the SS with the loop. */
9967 gfc_add_ss_to_loop (&loop
, lss
);
9968 gfc_add_ss_to_loop (&loop
, rss
);
9970 /* Calculate the bounds of the scalarization. */
9971 gfc_conv_ss_startstride (&loop
);
9972 /* Enable loop reversal. */
9973 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9974 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9975 /* Resolve any data dependencies in the statement. */
9977 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9978 /* Setup the scalarizing loops. */
9979 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9981 /* Setup the gfc_se structures. */
9982 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9983 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9986 gfc_mark_ss_chain_used (rss
, 1);
9987 if (loop
.temp_ss
== NULL
)
9990 gfc_mark_ss_chain_used (lss
, 1);
9994 lse
.ss
= loop
.temp_ss
;
9995 gfc_mark_ss_chain_used (lss
, 3);
9996 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9999 /* Allow the scalarizer to workshare array assignments. */
10000 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10001 == OMPWS_WORKSHARE_FLAG
10002 && loop
.temp_ss
== NULL
)
10004 maybe_workshare
= true;
10005 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10008 /* Start the scalarized loop body. */
10009 gfc_start_scalarized_body (&loop
, &body
);
10012 gfc_init_block (&body
);
10014 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10016 /* Translate the expression. */
10017 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10018 && lhs_caf_attr
.codimension
;
10019 gfc_conv_expr (&rse
, expr2
);
10021 /* Deal with the case of a scalar class function assigned to a derived type. */
10022 if (gfc_is_alloc_class_scalar_function (expr2
)
10023 && expr1
->ts
.type
== BT_DERIVED
)
10025 rse
.expr
= gfc_class_data_get (rse
.expr
);
10026 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10029 /* Stabilize a string length for temporaries. */
10030 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10031 && !(VAR_P (rse
.string_length
)
10032 || TREE_CODE (rse
.string_length
) == PARM_DECL
10033 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10034 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10035 else if (expr2
->ts
.type
== BT_CHARACTER
)
10036 string_length
= rse
.string_length
;
10038 string_length
= NULL_TREE
;
10042 gfc_conv_tmp_array_ref (&lse
);
10043 if (expr2
->ts
.type
== BT_CHARACTER
)
10044 lse
.string_length
= string_length
;
10048 gfc_conv_expr (&lse
, expr1
);
10049 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10051 && gfc_expr_attr (expr1
).allocatable
10058 tmp
= INDIRECT_REF_P (lse
.expr
)
10059 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10061 /* We should only get array references here. */
10062 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10063 || TREE_CODE (tmp
) == ARRAY_REF
);
10065 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10066 or the array itself(ARRAY_REF). */
10067 tmp
= TREE_OPERAND (tmp
, 0);
10069 /* Provide the address of the array. */
10070 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10071 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10073 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10074 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10075 msg
= _("Assignment of scalar to unallocated array");
10076 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10077 &expr1
->where
, msg
);
10080 /* Deallocate the lhs parameterized components if required. */
10081 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10082 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10084 if (expr1
->ts
.type
== BT_DERIVED
10085 && expr1
->ts
.u
.derived
10086 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10088 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10090 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10092 else if (expr1
->ts
.type
== BT_CLASS
10093 && CLASS_DATA (expr1
)->ts
.u
.derived
10094 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10096 tmp
= gfc_class_data_get (lse
.expr
);
10097 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10099 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10104 /* Assignments of scalar derived types with allocatable components
10105 to arrays must be done with a deep copy and the rhs temporary
10106 must have its components deallocated afterwards. */
10107 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10108 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10109 && !gfc_expr_is_variable (expr2
)
10110 && expr1
->rank
&& !expr2
->rank
);
10111 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10113 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10114 && gfc_is_alloc_class_scalar_function (expr2
));
10115 if (scalar_to_array
&& dealloc
)
10117 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10118 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10121 /* When assigning a character function result to a deferred-length variable,
10122 the function call must happen before the (re)allocation of the lhs -
10123 otherwise the character length of the result is not known.
10124 NOTE: This relies on having the exact dependence of the length type
10125 parameter available to the caller; gfortran saves it in the .mod files.
10126 NOTE ALSO: The concatenation operation generates a temporary pointer,
10127 whose allocation must go to the innermost loop.
10128 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10129 if (flag_realloc_lhs
10130 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10131 && !(lss
!= gfc_ss_terminator
10132 && ((expr2
->expr_type
== EXPR_OP
10133 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10134 || (expr2
->expr_type
== EXPR_FUNCTION
10135 && expr2
->value
.function
.isym
!= NULL
10136 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
))))
10137 gfc_add_block_to_block (&block
, &rse
.pre
);
10139 /* Nullify the allocatable components corresponding to those of the lhs
10140 derived type, so that the finalization of the function result does not
10141 affect the lhs of the assignment. Prepend is used to ensure that the
10142 nullification occurs before the call to the finalizer. In the case of
10143 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10144 as part of the deep copy. */
10145 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10146 && (gfc_is_class_array_function (expr2
)
10147 || gfc_is_alloc_class_scalar_function (expr2
)))
10150 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10151 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10152 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10153 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10156 if (is_poly_assign
)
10157 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10158 use_vptr_copy
|| (lhs_attr
.allocatable
10159 && !lhs_attr
.dimension
),
10160 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10161 else if (flag_coarray
== GFC_FCOARRAY_LIB
10162 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10163 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10164 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10166 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10167 allocatable component, because those need to be accessed via the
10168 caf-runtime. No need to check for coindexes here, because resolve
10169 has rewritten those already. */
10171 gfc_actual_arglist a1
, a2
;
10172 /* Clear the structures to prevent accessing garbage. */
10173 memset (&code
, '\0', sizeof (gfc_code
));
10174 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10175 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10180 code
.ext
.actual
= &a1
;
10181 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10182 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10185 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10186 gfc_expr_is_variable (expr2
)
10188 || expr2
->expr_type
== EXPR_ARRAY
,
10189 !(l_is_temp
|| init_flag
) && dealloc
,
10190 expr1
->symtree
->n
.sym
->attr
.codimension
);
10191 /* Add the pre blocks to the body. */
10192 gfc_add_block_to_block (&body
, &rse
.pre
);
10193 gfc_add_block_to_block (&body
, &lse
.pre
);
10194 gfc_add_expr_to_block (&body
, tmp
);
10195 /* Add the post blocks to the body. */
10196 gfc_add_block_to_block (&body
, &rse
.post
);
10197 gfc_add_block_to_block (&body
, &lse
.post
);
10199 if (lss
== gfc_ss_terminator
)
10201 /* F2003: Add the code for reallocation on assignment. */
10202 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10203 && !is_poly_assign
)
10204 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10207 /* Use the scalar assignment as is. */
10208 gfc_add_block_to_block (&block
, &body
);
10212 gcc_assert (lse
.ss
== gfc_ss_terminator
10213 && rse
.ss
== gfc_ss_terminator
);
10217 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10219 /* We need to copy the temporary to the actual lhs. */
10220 gfc_init_se (&lse
, NULL
);
10221 gfc_init_se (&rse
, NULL
);
10222 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10223 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10225 rse
.ss
= loop
.temp_ss
;
10228 gfc_conv_tmp_array_ref (&rse
);
10229 gfc_conv_expr (&lse
, expr1
);
10231 gcc_assert (lse
.ss
== gfc_ss_terminator
10232 && rse
.ss
== gfc_ss_terminator
);
10234 if (expr2
->ts
.type
== BT_CHARACTER
)
10235 rse
.string_length
= string_length
;
10237 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10239 gfc_add_expr_to_block (&body
, tmp
);
10242 /* F2003: Allocate or reallocate lhs of allocatable array. */
10243 if (flag_realloc_lhs
10244 && gfc_is_reallocatable_lhs (expr1
)
10246 && !is_runtime_conformable (expr1
, expr2
))
10248 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10249 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10250 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10251 if (tmp
!= NULL_TREE
)
10252 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10255 if (maybe_workshare
)
10256 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10258 /* Generate the copying loops. */
10259 gfc_trans_scalarizing_loops (&loop
, &body
);
10261 /* Wrap the whole thing up. */
10262 gfc_add_block_to_block (&block
, &loop
.pre
);
10263 gfc_add_block_to_block (&block
, &loop
.post
);
10265 gfc_cleanup_loop (&loop
);
10268 return gfc_finish_block (&block
);
10272 /* Check whether EXPR is a copyable array. */
10275 copyable_array_p (gfc_expr
* expr
)
10277 if (expr
->expr_type
!= EXPR_VARIABLE
)
10280 /* First check it's an array. */
10281 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10284 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10287 /* Next check that it's of a simple enough type. */
10288 switch (expr
->ts
.type
)
10300 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10309 /* Translate an assignment. */
10312 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10313 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10317 /* Special case a single function returning an array. */
10318 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10320 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10325 /* Special case assigning an array to zero. */
10326 if (copyable_array_p (expr1
)
10327 && is_zero_initializer_p (expr2
))
10329 tmp
= gfc_trans_zero_assign (expr1
);
10334 /* Special case copying one array to another. */
10335 if (copyable_array_p (expr1
)
10336 && copyable_array_p (expr2
)
10337 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10338 && !gfc_check_dependency (expr1
, expr2
, 0))
10340 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10345 /* Special case initializing an array from a constant array constructor. */
10346 if (copyable_array_p (expr1
)
10347 && expr2
->expr_type
== EXPR_ARRAY
10348 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10350 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10355 /* Fallback to the scalarizer to generate explicit loops. */
10356 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10357 use_vptr_copy
, may_alias
);
10361 gfc_trans_init_assign (gfc_code
* code
)
10363 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10367 gfc_trans_assign (gfc_code
* code
)
10369 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);