1 /* Expression translation
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (CONSTANT_CLASS_P (scalar
))
78 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
79 gfc_add_modify (&se
->pre
, tmp
, scalar
);
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
83 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
84 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
85 gfc_get_dtype (type
));
86 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
91 gfc_add_modify (&se
->post
, scalar
,
92 fold_convert (TREE_TYPE (scalar
),
93 gfc_conv_descriptor_data_get (desc
)));
98 /* Get the coarray token from the ultimate array or component ref.
99 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
102 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
104 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
105 bool is_coarray
= sym
->attr
.codimension
;
106 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
107 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
111 if (ref
->type
== REF_COMPONENT
112 && (ref
->u
.c
.component
->attr
.allocatable
113 || ref
->u
.c
.component
->attr
.pointer
)
114 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
119 if (last_caf_ref
== NULL
)
122 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
124 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
125 if (comp
== NULL_TREE
&& comp_ref
)
127 gfc_init_se (&se
, outerse
);
128 gfc_free_ref_list (last_caf_ref
->next
);
129 last_caf_ref
->next
= NULL
;
130 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
131 se
.want_pointer
= comp_ref
;
132 gfc_conv_expr (&se
, caf_expr
);
133 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
135 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
136 se
.expr
= TREE_OPERAND (se
.expr
, 0);
137 gfc_free_expr (caf_expr
);
140 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
141 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
143 caf
= gfc_conv_descriptor_token (se
.expr
);
144 return gfc_build_addr_expr (NULL_TREE
, caf
);
148 /* This is the seed for an eventual trans-class.c
150 The following parameters should not be used directly since they might
151 in future implementations. Use the corresponding APIs. */
152 #define CLASS_DATA_FIELD 0
153 #define CLASS_VPTR_FIELD 1
154 #define CLASS_LEN_FIELD 2
155 #define VTABLE_HASH_FIELD 0
156 #define VTABLE_SIZE_FIELD 1
157 #define VTABLE_EXTENDS_FIELD 2
158 #define VTABLE_DEF_INIT_FIELD 3
159 #define VTABLE_COPY_FIELD 4
160 #define VTABLE_FINAL_FIELD 5
161 #define VTABLE_DEALLOCATE_FIELD 6
165 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
169 vec
<constructor_elt
, va_gc
> *init
= NULL
;
171 field
= TYPE_FIELDS (TREE_TYPE (decl
));
172 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
173 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
175 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
178 return build_constructor (TREE_TYPE (decl
), init
);
183 gfc_class_data_get (tree decl
)
186 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
187 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
188 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
190 return fold_build3_loc (input_location
, COMPONENT_REF
,
191 TREE_TYPE (data
), decl
, data
,
197 gfc_class_vptr_get (tree decl
)
200 /* For class arrays decl may be a temporary descriptor handle, the vptr is
201 then available through the saved descriptor. */
202 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
204 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
205 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
206 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
207 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
209 return fold_build3_loc (input_location
, COMPONENT_REF
,
210 TREE_TYPE (vptr
), decl
, vptr
,
216 gfc_class_len_get (tree decl
)
219 /* For class arrays decl may be a temporary descriptor handle, the len is
220 then available through the saved descriptor. */
221 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
222 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
223 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
224 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
225 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
226 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
228 return fold_build3_loc (input_location
, COMPONENT_REF
,
229 TREE_TYPE (len
), decl
, len
,
234 /* Try to get the _len component of a class. When the class is not unlimited
235 poly, i.e. no _len field exists, then return a zero node. */
238 gfc_class_len_or_zero_get (tree decl
)
241 /* For class arrays decl may be a temporary descriptor handle, the vptr is
242 then available through the saved descriptor. */
243 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
244 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
245 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
246 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
247 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
248 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
250 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
251 TREE_TYPE (len
), decl
, len
,
257 /* Get the specified FIELD from the VPTR. */
260 vptr_field_get (tree vptr
, int fieldno
)
263 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
264 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
266 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
267 TREE_TYPE (field
), vptr
, field
,
274 /* Get the field from the class' vptr. */
277 class_vtab_field_get (tree decl
, int fieldno
)
280 vptr
= gfc_class_vptr_get (decl
);
281 return vptr_field_get (vptr
, fieldno
);
285 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
287 #define VTAB_GET_FIELD_GEN(name, field) tree \
288 gfc_class_vtab_## name ##_get (tree cl) \
290 return class_vtab_field_get (cl, field); \
294 gfc_vptr_## name ##_get (tree vptr) \
296 return vptr_field_get (vptr, field); \
299 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
300 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
301 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
302 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
303 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
304 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
307 /* The size field is returned as an array index type. Therefore treat
308 it and only it specially. */
311 gfc_class_vtab_size_get (tree cl
)
314 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
315 /* Always return size as an array index type. */
316 size
= fold_convert (gfc_array_index_type
, size
);
322 gfc_vptr_size_get (tree vptr
)
325 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
326 /* Always return size as an array index type. */
327 size
= fold_convert (gfc_array_index_type
, size
);
333 #undef CLASS_DATA_FIELD
334 #undef CLASS_VPTR_FIELD
335 #undef CLASS_LEN_FIELD
336 #undef VTABLE_HASH_FIELD
337 #undef VTABLE_SIZE_FIELD
338 #undef VTABLE_EXTENDS_FIELD
339 #undef VTABLE_DEF_INIT_FIELD
340 #undef VTABLE_COPY_FIELD
341 #undef VTABLE_FINAL_FIELD
344 /* Search for the last _class ref in the chain of references of this
345 expression and cut the chain there. Albeit this routine is similiar
346 to class.c::gfc_add_component_ref (), is there a significant
347 difference: gfc_add_component_ref () concentrates on an array ref to
348 be the last ref in the chain. This routine is oblivious to the kind
349 of refs following. */
352 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
355 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
357 /* Find the last class reference. */
360 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
362 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
365 if (ref
->type
== REF_COMPONENT
366 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
368 /* Component to the right of a part reference with nonzero rank
369 must not have the ALLOCATABLE attribute. If attempts are
370 made to reference such a component reference, an error results
371 followed by an ICE. */
372 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
377 if (ref
->next
== NULL
)
381 /* Remove and store all subsequent references after the
385 tail
= class_ref
->next
;
386 class_ref
->next
= NULL
;
388 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
394 base_expr
= gfc_expr_to_initialize (e
);
396 /* Restore the original tail expression. */
399 gfc_free_ref_list (class_ref
->next
);
400 class_ref
->next
= tail
;
402 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
404 gfc_free_ref_list (e
->ref
);
411 /* Reset the vptr to the declared type, e.g. after deallocation. */
414 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
421 /* Evaluate the expression and obtain the vptr from it. */
422 gfc_init_se (&se
, NULL
);
424 gfc_conv_expr_descriptor (&se
, e
);
426 gfc_conv_expr (&se
, e
);
427 gfc_add_block_to_block (block
, &se
.pre
);
428 vptr
= gfc_get_vptr_from_expr (se
.expr
);
430 /* If a vptr is not found, we can do nothing more. */
431 if (vptr
== NULL_TREE
)
434 if (UNLIMITED_POLY (e
))
435 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
438 /* Return the vptr to the address of the declared type. */
439 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
440 vtable
= vtab
->backend_decl
;
441 if (vtable
== NULL_TREE
)
442 vtable
= gfc_get_symbol_decl (vtab
);
443 vtable
= gfc_build_addr_expr (NULL
, vtable
);
444 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
445 gfc_add_modify (block
, vptr
, vtable
);
450 /* Reset the len for unlimited polymorphic objects. */
453 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
457 e
= gfc_find_and_cut_at_last_class_ref (expr
);
460 gfc_add_len_component (e
);
461 gfc_init_se (&se_len
, NULL
);
462 gfc_conv_expr (&se_len
, e
);
463 gfc_add_modify (block
, se_len
.expr
,
464 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
469 /* Obtain the vptr of the last class reference in an expression.
470 Return NULL_TREE if no class reference is found. */
473 gfc_get_vptr_from_expr (tree expr
)
478 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
480 type
= TREE_TYPE (tmp
);
483 if (GFC_CLASS_TYPE_P (type
))
484 return gfc_class_vptr_get (tmp
);
485 if (type
!= TYPE_CANONICAL (type
))
486 type
= TYPE_CANONICAL (type
);
490 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
494 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
495 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
497 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
498 return gfc_class_vptr_get (tmp
);
505 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
508 tree tmp
, tmp2
, type
;
510 gfc_conv_descriptor_data_set (block
, lhs_desc
,
511 gfc_conv_descriptor_data_get (rhs_desc
));
512 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
513 gfc_conv_descriptor_offset_get (rhs_desc
));
515 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
516 gfc_conv_descriptor_dtype (rhs_desc
));
518 /* Assign the dimension as range-ref. */
519 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
520 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
522 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
523 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
524 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
525 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
526 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
527 gfc_add_modify (block
, tmp
, tmp2
);
531 /* Takes a derived type expression and returns the address of a temporary
532 class object of the 'declared' type. If vptr is not NULL, this is
533 used for the temporary class object.
534 optional_alloc_ptr is false when the dummy is neither allocatable
535 nor a pointer; that's only relevant for the optional handling. */
537 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
538 gfc_typespec class_ts
, tree vptr
, bool optional
,
539 bool optional_alloc_ptr
)
542 tree cond_optional
= NULL_TREE
;
548 /* The derived type needs to be converted to a temporary
550 tmp
= gfc_typenode_for_spec (&class_ts
);
551 var
= gfc_create_var (tmp
, "class");
554 ctree
= gfc_class_vptr_get (var
);
556 if (vptr
!= NULL_TREE
)
558 /* Use the dynamic vptr. */
563 /* In this case the vtab corresponds to the derived type and the
564 vptr must point to it. */
565 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
567 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
569 gfc_add_modify (&parmse
->pre
, ctree
,
570 fold_convert (TREE_TYPE (ctree
), tmp
));
572 /* Now set the data field. */
573 ctree
= gfc_class_data_get (var
);
576 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
578 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
580 /* If there is a ready made pointer to a derived type, use it
581 rather than evaluating the expression again. */
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
585 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
587 /* For an array reference in an elemental procedure call we need
588 to retain the ss to provide the scalarized array reference. */
589 gfc_conv_expr_reference (parmse
, e
);
590 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
592 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
594 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
595 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
599 ss
= gfc_walk_expr (e
);
600 if (ss
== gfc_ss_terminator
)
603 gfc_conv_expr_reference (parmse
, e
);
605 /* Scalar to an assumed-rank array. */
606 if (class_ts
.u
.derived
->components
->as
)
609 type
= get_scalar_to_descriptor_type (parmse
->expr
,
611 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
612 gfc_get_dtype (type
));
614 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
615 TREE_TYPE (parmse
->expr
),
616 cond_optional
, parmse
->expr
,
617 fold_convert (TREE_TYPE (parmse
->expr
),
619 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
623 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
625 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
627 fold_convert (TREE_TYPE (tmp
),
629 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
635 gfc_init_block (&block
);
638 gfc_conv_expr_descriptor (parmse
, e
);
640 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
642 gcc_assert (class_ts
.u
.derived
->components
->as
->type
644 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
648 if (gfc_expr_attr (e
).codimension
)
649 parmse
->expr
= fold_build1_loc (input_location
,
653 gfc_add_modify (&block
, ctree
, parmse
->expr
);
658 tmp
= gfc_finish_block (&block
);
660 gfc_init_block (&block
);
661 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
663 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
664 gfc_finish_block (&block
));
665 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
668 gfc_add_block_to_block (&parmse
->pre
, &block
);
672 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
673 && class_ts
.u
.derived
->components
->ts
.u
.derived
674 ->attr
.unlimited_polymorphic
)
676 /* Take care about initializing the _len component correctly. */
677 ctree
= gfc_class_len_get (var
);
678 if (UNLIMITED_POLY (e
))
683 len
= gfc_copy_expr (e
);
684 gfc_add_len_component (len
);
685 gfc_init_se (&se
, NULL
);
686 gfc_conv_expr (&se
, len
);
688 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
689 cond_optional
, se
.expr
,
690 fold_convert (TREE_TYPE (se
.expr
),
696 tmp
= integer_zero_node
;
697 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
700 /* Pass the address of the class object. */
701 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
703 if (optional
&& optional_alloc_ptr
)
704 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
705 TREE_TYPE (parmse
->expr
),
706 cond_optional
, parmse
->expr
,
707 fold_convert (TREE_TYPE (parmse
->expr
),
712 /* Create a new class container, which is required as scalar coarrays
713 have an array descriptor while normal scalars haven't. Optionally,
714 NULL pointer checks are added if the argument is OPTIONAL. */
717 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
718 gfc_typespec class_ts
, bool optional
)
720 tree var
, ctree
, tmp
;
725 gfc_init_block (&block
);
728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
730 if (ref
->type
== REF_COMPONENT
731 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 var
= gfc_typenode_for_spec (&class_ts
);
752 var
= gfc_create_var (var
, "class");
754 ctree
= gfc_class_vptr_get (var
);
755 gfc_add_modify (&block
, ctree
,
756 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
758 ctree
= gfc_class_data_get (var
);
759 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
760 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
762 /* Pass the address of the class object. */
763 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
767 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
770 tmp
= gfc_finish_block (&block
);
772 gfc_init_block (&block
);
773 tmp2
= gfc_class_data_get (var
);
774 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
776 tmp2
= gfc_finish_block (&block
);
778 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
780 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
783 gfc_add_block_to_block (&parmse
->pre
, &block
);
787 /* Takes an intrinsic type expression and returns the address of a temporary
788 class object of the 'declared' type. */
790 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
791 gfc_typespec class_ts
)
799 /* The intrinsic type needs to be converted to a temporary
801 tmp
= gfc_typenode_for_spec (&class_ts
);
802 var
= gfc_create_var (tmp
, "class");
805 ctree
= gfc_class_vptr_get (var
);
807 vtab
= gfc_find_vtab (&e
->ts
);
809 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
810 gfc_add_modify (&parmse
->pre
, ctree
,
811 fold_convert (TREE_TYPE (ctree
), tmp
));
813 /* Now set the data field. */
814 ctree
= gfc_class_data_get (var
);
815 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
817 /* For an array reference in an elemental procedure call we need
818 to retain the ss to provide the scalarized array reference. */
819 gfc_conv_expr_reference (parmse
, e
);
820 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
821 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
825 ss
= gfc_walk_expr (e
);
826 if (ss
== gfc_ss_terminator
)
829 gfc_conv_expr_reference (parmse
, e
);
830 if (class_ts
.u
.derived
->components
->as
831 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
833 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
835 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
836 TREE_TYPE (ctree
), tmp
);
839 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
840 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
845 parmse
->use_offset
= 1;
846 gfc_conv_expr_descriptor (parmse
, e
);
847 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
849 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
850 TREE_TYPE (ctree
), parmse
->expr
);
851 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
854 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
858 gcc_assert (class_ts
.type
== BT_CLASS
);
859 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
860 && class_ts
.u
.derived
->components
->ts
.u
.derived
861 ->attr
.unlimited_polymorphic
)
863 ctree
= gfc_class_len_get (var
);
864 /* When the actual arg is a char array, then set the _len component of the
865 unlimited polymorphic entity to the length of the string. */
866 if (e
->ts
.type
== BT_CHARACTER
)
868 /* Start with parmse->string_length because this seems to be set to a
869 correct value more often. */
870 if (parmse
->string_length
)
871 tmp
= parmse
->string_length
;
872 /* When the string_length is not yet set, then try the backend_decl of
874 else if (e
->ts
.u
.cl
->backend_decl
)
875 tmp
= e
->ts
.u
.cl
->backend_decl
;
876 /* If both of the above approaches fail, then try to generate an
877 expression from the input, which is only feasible currently, when the
878 expression can be evaluated to a constant one. */
881 /* Try to simplify the expression. */
882 gfc_simplify_expr (e
, 0);
883 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
885 /* Amazingly all data is present to compute the length of a
886 constant string, but the expression is not yet there. */
887 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
889 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
890 e
->value
.character
.length
);
891 gfc_conv_const_charlen (e
->ts
.u
.cl
);
892 e
->ts
.u
.cl
->resolved
= 1;
893 tmp
= e
->ts
.u
.cl
->backend_decl
;
897 gfc_error ("Can't compute the length of the char array at %L.",
903 tmp
= integer_zero_node
;
905 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
907 else if (class_ts
.type
== BT_CLASS
908 && class_ts
.u
.derived
->components
909 && class_ts
.u
.derived
->components
->ts
.u
910 .derived
->attr
.unlimited_polymorphic
)
912 ctree
= gfc_class_len_get (var
);
913 gfc_add_modify (&parmse
->pre
, ctree
,
914 fold_convert (TREE_TYPE (ctree
),
917 /* Pass the address of the class object. */
918 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
922 /* Takes a scalarized class array expression and returns the
923 address of a temporary scalar class object of the 'declared'
925 OOP-TODO: This could be improved by adding code that branched on
926 the dynamic type being the same as the declared type. In this case
927 the original class expression can be passed directly.
928 optional_alloc_ptr is false when the dummy is neither allocatable
929 nor a pointer; that's relevant for the optional handling.
930 Set copyback to true if class container's _data and _vtab pointers
931 might get modified. */
934 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
935 bool elemental
, bool copyback
, bool optional
,
936 bool optional_alloc_ptr
)
942 tree cond
= NULL_TREE
;
943 tree slen
= NULL_TREE
;
947 bool full_array
= false;
949 gfc_init_block (&block
);
952 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
954 if (ref
->type
== REF_COMPONENT
955 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
958 if (ref
->next
== NULL
)
962 if ((ref
== NULL
|| class_ref
== ref
)
963 && !(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
))
2406 tmp
= c
->ts
.u
.cl
->backend_decl
;
2407 /* Components must always be constant length. */
2408 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2409 se
->string_length
= tmp
;
2412 if (gfc_deferred_strlen (c
, &field
))
2414 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2416 decl
, field
, NULL_TREE
);
2417 se
->string_length
= tmp
;
2420 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2421 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2422 && c
->ts
.type
!= BT_CHARACTER
)
2423 || c
->attr
.proc_pointer
)
2424 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2429 /* This function deals with component references to components of the
2430 parent type for derived type extensions. */
2432 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2440 c
= ref
->u
.c
.component
;
2442 /* Return if the component is in the parent type. */
2443 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2444 if (strcmp (c
->name
, cmp
->name
) == 0)
2447 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2448 parent
.type
= REF_COMPONENT
;
2450 parent
.u
.c
.sym
= dt
;
2451 parent
.u
.c
.component
= dt
->components
;
2453 if (dt
->backend_decl
== NULL
)
2454 gfc_get_derived_type (dt
);
2456 /* Build the reference and call self. */
2457 gfc_conv_component_ref (se
, &parent
);
2458 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2459 parent
.u
.c
.component
= c
;
2460 conv_parent_component_references (se
, &parent
);
2463 /* Return the contents of a variable. Also handles reference/pointer
2464 variables (all Fortran pointer references are implicit). */
2467 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2472 tree parent_decl
= NULL_TREE
;
2475 bool alternate_entry
;
2478 bool first_time
= true;
2480 sym
= expr
->symtree
->n
.sym
;
2481 is_classarray
= IS_CLASS_ARRAY (sym
);
2485 gfc_ss_info
*ss_info
= ss
->info
;
2487 /* Check that something hasn't gone horribly wrong. */
2488 gcc_assert (ss
!= gfc_ss_terminator
);
2489 gcc_assert (ss_info
->expr
== expr
);
2491 /* A scalarized term. We already know the descriptor. */
2492 se
->expr
= ss_info
->data
.array
.descriptor
;
2493 se
->string_length
= ss_info
->string_length
;
2494 ref
= ss_info
->data
.array
.ref
;
2496 gcc_assert (ref
->type
== REF_ARRAY
2497 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2499 gfc_conv_tmp_array_ref (se
);
2503 tree se_expr
= NULL_TREE
;
2505 se
->expr
= gfc_get_symbol_decl (sym
);
2507 /* Deal with references to a parent results or entries by storing
2508 the current_function_decl and moving to the parent_decl. */
2509 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2510 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2511 && sym
->result
== sym
;
2512 entry_master
= sym
->attr
.result
2513 && sym
->ns
->proc_name
->attr
.entry_master
2514 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2515 if (current_function_decl
)
2516 parent_decl
= DECL_CONTEXT (current_function_decl
);
2518 if ((se
->expr
== parent_decl
&& return_value
)
2519 || (sym
->ns
&& sym
->ns
->proc_name
2521 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2522 && (alternate_entry
|| entry_master
)))
2527 /* Special case for assigning the return value of a function.
2528 Self recursive functions must have an explicit return value. */
2529 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2530 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2532 /* Similarly for alternate entry points. */
2533 else if (alternate_entry
2534 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2537 gfc_entry_list
*el
= NULL
;
2539 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2542 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2547 else if (entry_master
2548 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2550 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2555 /* Procedure actual arguments. Look out for temporary variables
2556 with the same attributes as function values. */
2557 else if (!sym
->attr
.temporary
2558 && sym
->attr
.flavor
== FL_PROCEDURE
2559 && se
->expr
!= current_function_decl
)
2561 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2563 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2564 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2570 /* Dereference the expression, where needed. Since characters
2571 are entirely different from other types, they are treated
2573 if (sym
->ts
.type
== BT_CHARACTER
)
2575 /* Dereference character pointer dummy arguments
2577 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2579 || sym
->attr
.function
2580 || sym
->attr
.result
))
2581 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2585 else if (!sym
->attr
.value
)
2587 /* Dereference temporaries for class array dummy arguments. */
2588 if (sym
->attr
.dummy
&& is_classarray
2589 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2591 if (!se
->descriptor_only
)
2592 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2594 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2598 /* Dereference non-character scalar dummy arguments. */
2599 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2600 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2601 && (sym
->ts
.type
!= BT_CLASS
2602 || (!CLASS_DATA (sym
)->attr
.dimension
2603 && !(CLASS_DATA (sym
)->attr
.codimension
2604 && CLASS_DATA (sym
)->attr
.allocatable
))))
2605 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2608 /* Dereference scalar hidden result. */
2609 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2610 && (sym
->attr
.function
|| sym
->attr
.result
)
2611 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2612 && !sym
->attr
.always_explicit
)
2613 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2616 /* Dereference non-character, non-class pointer variables.
2617 These must be dummies, results, or scalars. */
2619 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2620 || gfc_is_associate_pointer (sym
)
2621 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2623 || sym
->attr
.function
2625 || (!sym
->attr
.dimension
2626 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2627 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2629 /* Now treat the class array pointer variables accordingly. */
2630 else if (sym
->ts
.type
== BT_CLASS
2632 && (CLASS_DATA (sym
)->attr
.dimension
2633 || CLASS_DATA (sym
)->attr
.codimension
)
2634 && ((CLASS_DATA (sym
)->as
2635 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2636 || CLASS_DATA (sym
)->attr
.allocatable
2637 || CLASS_DATA (sym
)->attr
.class_pointer
))
2638 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2640 /* And the case where a non-dummy, non-result, non-function,
2641 non-allotable and non-pointer classarray is present. This case was
2642 previously covered by the first if, but with introducing the
2643 condition !is_classarray there, that case has to be covered
2645 else if (sym
->ts
.type
== BT_CLASS
2647 && !sym
->attr
.function
2648 && !sym
->attr
.result
2649 && (CLASS_DATA (sym
)->attr
.dimension
2650 || CLASS_DATA (sym
)->attr
.codimension
)
2652 || !CLASS_DATA (sym
)->attr
.allocatable
)
2653 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2654 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2661 /* For character variables, also get the length. */
2662 if (sym
->ts
.type
== BT_CHARACTER
)
2664 /* If the character length of an entry isn't set, get the length from
2665 the master function instead. */
2666 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2667 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2669 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2670 gcc_assert (se
->string_length
);
2678 /* Return the descriptor if that's what we want and this is an array
2679 section reference. */
2680 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2682 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2683 /* Return the descriptor for array pointers and allocations. */
2684 if (se
->want_pointer
2685 && ref
->next
== NULL
&& (se
->descriptor_only
))
2688 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2689 /* Return a pointer to an element. */
2693 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2694 && se
->descriptor_only
2695 && !CLASS_DATA (sym
)->attr
.allocatable
2696 && !CLASS_DATA (sym
)->attr
.class_pointer
2697 && CLASS_DATA (sym
)->as
2698 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2699 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2700 /* Skip the first ref of a _data component, because for class
2701 arrays that one is already done by introducing a temporary
2702 array descriptor. */
2705 if (ref
->u
.c
.sym
->attr
.extension
)
2706 conv_parent_component_references (se
, ref
);
2708 gfc_conv_component_ref (se
, ref
);
2709 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2710 && se
->want_pointer
&& se
->descriptor_only
)
2716 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2717 expr
->symtree
->name
, &expr
->where
);
2727 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2729 if (se
->want_pointer
)
2731 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2732 gfc_conv_string_parameter (se
);
2734 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2739 /* Unary ops are easy... Or they would be if ! was a valid op. */
2742 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2747 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2748 /* Initialize the operand. */
2749 gfc_init_se (&operand
, se
);
2750 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2751 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2753 type
= gfc_typenode_for_spec (&expr
->ts
);
2755 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2756 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2757 All other unary operators have an equivalent GIMPLE unary operator. */
2758 if (code
== TRUTH_NOT_EXPR
)
2759 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2760 build_int_cst (type
, 0));
2762 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2766 /* Expand power operator to optimal multiplications when a value is raised
2767 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2768 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2769 Programming", 3rd Edition, 1998. */
2771 /* This code is mostly duplicated from expand_powi in the backend.
2772 We establish the "optimal power tree" lookup table with the defined size.
2773 The items in the table are the exponents used to calculate the index
2774 exponents. Any integer n less than the value can get an "addition chain",
2775 with the first node being one. */
2776 #define POWI_TABLE_SIZE 256
2778 /* The table is from builtins.c. */
2779 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2781 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2782 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2783 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2784 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2785 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2786 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2787 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2788 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2789 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2790 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2791 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2792 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2793 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2794 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2795 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2796 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2797 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2798 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2799 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2800 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2801 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2802 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2803 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2804 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2805 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2806 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2807 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2808 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2809 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2810 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2811 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2812 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2815 /* If n is larger than lookup table's max index, we use the "window
2817 #define POWI_WINDOW_SIZE 3
2819 /* Recursive function to expand the power operator. The temporary
2820 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2822 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2829 if (n
< POWI_TABLE_SIZE
)
2834 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2835 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2839 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2840 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2841 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2845 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2849 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2850 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2852 if (n
< POWI_TABLE_SIZE
)
2859 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2860 return 1. Else return 0 and a call to runtime library functions
2861 will have to be built. */
2863 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2868 tree vartmp
[POWI_TABLE_SIZE
];
2870 unsigned HOST_WIDE_INT n
;
2872 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2874 /* If exponent is too large, we won't expand it anyway, so don't bother
2875 with large integer values. */
2876 if (!wi::fits_shwi_p (wrhs
))
2879 m
= wrhs
.to_shwi ();
2880 /* Use the wide_int's routine to reliably get the absolute value on all
2881 platforms. Then convert it to a HOST_WIDE_INT like above. */
2882 n
= wi::abs (wrhs
).to_shwi ();
2884 type
= TREE_TYPE (lhs
);
2885 sgn
= tree_int_cst_sgn (rhs
);
2887 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2888 || optimize_size
) && (m
> 2 || m
< -1))
2894 se
->expr
= gfc_build_const (type
, integer_one_node
);
2898 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2899 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2901 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2902 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2903 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2904 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2907 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2910 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2911 logical_type_node
, tmp
, cond
);
2912 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2913 tmp
, build_int_cst (type
, 1),
2914 build_int_cst (type
, 0));
2918 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2919 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2920 build_int_cst (type
, -1),
2921 build_int_cst (type
, 0));
2922 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2923 cond
, build_int_cst (type
, 1), tmp
);
2927 memset (vartmp
, 0, sizeof (vartmp
));
2931 tmp
= gfc_build_const (type
, integer_one_node
);
2932 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2936 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2942 /* Power op (**). Constant integer exponent has special handling. */
2945 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2947 tree gfc_int4_type_node
;
2950 int res_ikind_1
, res_ikind_2
;
2955 gfc_init_se (&lse
, se
);
2956 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2957 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2958 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2960 gfc_init_se (&rse
, se
);
2961 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2962 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2964 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2965 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2966 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2969 gfc_int4_type_node
= gfc_get_int_type (4);
2971 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2972 library routine. But in the end, we have to convert the result back
2973 if this case applies -- with res_ikind_K, we keep track whether operand K
2974 falls into this case. */
2978 kind
= expr
->value
.op
.op1
->ts
.kind
;
2979 switch (expr
->value
.op
.op2
->ts
.type
)
2982 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2987 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2988 res_ikind_2
= ikind
;
3010 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3012 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3039 switch (expr
->value
.op
.op1
->ts
.type
)
3042 if (kind
== 3) /* Case 16 was not handled properly above. */
3044 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3048 /* Use builtins for real ** int4. */
3054 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3058 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3062 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3066 /* Use the __builtin_powil() only if real(kind=16) is
3067 actually the C long double type. */
3068 if (!gfc_real16_is_float128
)
3069 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3077 /* If we don't have a good builtin for this, go for the
3078 library function. */
3080 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3084 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3093 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3097 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3105 se
->expr
= build_call_expr_loc (input_location
,
3106 fndecl
, 2, lse
.expr
, rse
.expr
);
3108 /* Convert the result back if it is of wrong integer kind. */
3109 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3111 /* We want the maximum of both operand kinds as result. */
3112 if (res_ikind_1
< res_ikind_2
)
3113 res_ikind_1
= res_ikind_2
;
3114 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3119 /* Generate code to allocate a string temporary. */
3122 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3127 if (gfc_can_put_var_on_stack (len
))
3129 /* Create a temporary variable to hold the result. */
3130 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3131 gfc_charlen_type_node
, len
,
3132 build_int_cst (gfc_charlen_type_node
, 1));
3133 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3135 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3136 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3138 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3140 var
= gfc_create_var (tmp
, "str");
3141 var
= gfc_build_addr_expr (type
, var
);
3145 /* Allocate a temporary to hold the result. */
3146 var
= gfc_create_var (type
, "pstr");
3147 gcc_assert (POINTER_TYPE_P (type
));
3148 tmp
= TREE_TYPE (type
);
3149 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3150 tmp
= TREE_TYPE (tmp
);
3151 tmp
= TYPE_SIZE_UNIT (tmp
);
3152 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3153 fold_convert (size_type_node
, len
),
3154 fold_convert (size_type_node
, tmp
));
3155 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3156 gfc_add_modify (&se
->pre
, var
, tmp
);
3158 /* Free the temporary afterwards. */
3159 tmp
= gfc_call_free (var
);
3160 gfc_add_expr_to_block (&se
->post
, tmp
);
3167 /* Handle a string concatenation operation. A temporary will be allocated to
3171 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3174 tree len
, type
, var
, tmp
, fndecl
;
3176 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3177 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3178 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3180 gfc_init_se (&lse
, se
);
3181 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3182 gfc_conv_string_parameter (&lse
);
3183 gfc_init_se (&rse
, se
);
3184 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3185 gfc_conv_string_parameter (&rse
);
3187 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3188 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3190 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3191 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3192 if (len
== NULL_TREE
)
3194 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3195 TREE_TYPE (lse
.string_length
),
3196 lse
.string_length
, rse
.string_length
);
3199 type
= build_pointer_type (type
);
3201 var
= gfc_conv_string_tmp (se
, type
, len
);
3203 /* Do the actual concatenation. */
3204 if (expr
->ts
.kind
== 1)
3205 fndecl
= gfor_fndecl_concat_string
;
3206 else if (expr
->ts
.kind
== 4)
3207 fndecl
= gfor_fndecl_concat_string_char4
;
3211 tmp
= build_call_expr_loc (input_location
,
3212 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3213 rse
.string_length
, rse
.expr
);
3214 gfc_add_expr_to_block (&se
->pre
, tmp
);
3216 /* Add the cleanup for the operands. */
3217 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3218 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3221 se
->string_length
= len
;
3224 /* Translates an op expression. Common (binary) cases are handled by this
3225 function, others are passed on. Recursion is used in either case.
3226 We use the fact that (op1.ts == op2.ts) (except for the power
3228 Operators need no special handling for scalarized expressions as long as
3229 they call gfc_conv_simple_val to get their operands.
3230 Character strings get special handling. */
3233 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3235 enum tree_code code
;
3244 switch (expr
->value
.op
.op
)
3246 case INTRINSIC_PARENTHESES
:
3247 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3248 && flag_protect_parens
)
3250 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3251 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3256 case INTRINSIC_UPLUS
:
3257 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3260 case INTRINSIC_UMINUS
:
3261 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3265 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3268 case INTRINSIC_PLUS
:
3272 case INTRINSIC_MINUS
:
3276 case INTRINSIC_TIMES
:
3280 case INTRINSIC_DIVIDE
:
3281 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3282 an integer, we must round towards zero, so we use a
3284 if (expr
->ts
.type
== BT_INTEGER
)
3285 code
= TRUNC_DIV_EXPR
;
3290 case INTRINSIC_POWER
:
3291 gfc_conv_power_op (se
, expr
);
3294 case INTRINSIC_CONCAT
:
3295 gfc_conv_concat_op (se
, expr
);
3299 code
= TRUTH_ANDIF_EXPR
;
3304 code
= TRUTH_ORIF_EXPR
;
3308 /* EQV and NEQV only work on logicals, but since we represent them
3309 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3311 case INTRINSIC_EQ_OS
:
3319 case INTRINSIC_NE_OS
:
3320 case INTRINSIC_NEQV
:
3327 case INTRINSIC_GT_OS
:
3334 case INTRINSIC_GE_OS
:
3341 case INTRINSIC_LT_OS
:
3348 case INTRINSIC_LE_OS
:
3354 case INTRINSIC_USER
:
3355 case INTRINSIC_ASSIGN
:
3356 /* These should be converted into function calls by the frontend. */
3360 fatal_error (input_location
, "Unknown intrinsic op");
3364 /* The only exception to this is **, which is handled separately anyway. */
3365 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3367 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3371 gfc_init_se (&lse
, se
);
3372 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3373 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3376 gfc_init_se (&rse
, se
);
3377 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3378 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3382 gfc_conv_string_parameter (&lse
);
3383 gfc_conv_string_parameter (&rse
);
3385 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3386 rse
.string_length
, rse
.expr
,
3387 expr
->value
.op
.op1
->ts
.kind
,
3389 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3390 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3393 type
= gfc_typenode_for_spec (&expr
->ts
);
3397 /* The result of logical ops is always logical_type_node. */
3398 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3399 lse
.expr
, rse
.expr
);
3400 se
->expr
= convert (type
, tmp
);
3403 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3405 /* Add the post blocks. */
3406 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3407 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3410 /* If a string's length is one, we convert it to a single character. */
3413 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3417 || !tree_fits_uhwi_p (len
)
3418 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3421 if (TREE_INT_CST_LOW (len
) == 1)
3423 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3424 return build_fold_indirect_ref_loc (input_location
, str
);
3428 && TREE_CODE (str
) == ADDR_EXPR
3429 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3430 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3431 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3432 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3433 && TREE_INT_CST_LOW (len
) > 1
3434 && TREE_INT_CST_LOW (len
)
3435 == (unsigned HOST_WIDE_INT
)
3436 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3438 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3439 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3440 if (TREE_CODE (ret
) == INTEGER_CST
)
3442 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3443 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3444 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3446 for (i
= 1; i
< length
; i
++)
3459 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3462 if (sym
->backend_decl
)
3464 /* This becomes the nominal_type in
3465 function.c:assign_parm_find_data_types. */
3466 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3467 /* This becomes the passed_type in
3468 function.c:assign_parm_find_data_types. C promotes char to
3469 integer for argument passing. */
3470 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3472 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3477 /* If we have a constant character expression, make it into an
3479 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3484 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3485 (int)(*expr
)->value
.character
.string
[0]);
3486 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3488 /* The expr needs to be compatible with a C int. If the
3489 conversion fails, then the 2 causes an ICE. */
3490 ts
.type
= BT_INTEGER
;
3491 ts
.kind
= gfc_c_int_kind
;
3492 gfc_convert_type (*expr
, &ts
, 2);
3495 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3497 if ((*expr
)->ref
== NULL
)
3499 se
->expr
= gfc_string_to_single_character
3500 (build_int_cst (integer_type_node
, 1),
3501 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3503 ((*expr
)->symtree
->n
.sym
)),
3508 gfc_conv_variable (se
, *expr
);
3509 se
->expr
= gfc_string_to_single_character
3510 (build_int_cst (integer_type_node
, 1),
3511 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3519 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3520 if STR is a string literal, otherwise return -1. */
3523 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3526 && TREE_CODE (str
) == ADDR_EXPR
3527 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3528 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3529 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3530 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3531 && tree_fits_uhwi_p (len
)
3532 && tree_to_uhwi (len
) >= 1
3533 && tree_to_uhwi (len
)
3534 == (unsigned HOST_WIDE_INT
)
3535 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3537 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3538 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3539 if (TREE_CODE (folded
) == INTEGER_CST
)
3541 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3542 int length
= TREE_STRING_LENGTH (string_cst
);
3543 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3545 for (; length
> 0; length
--)
3546 if (ptr
[length
- 1] != ' ')
3555 /* Helper to build a call to memcmp. */
3558 build_memcmp_call (tree s1
, tree s2
, tree n
)
3562 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3563 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3565 s1
= fold_convert (pvoid_type_node
, s1
);
3567 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3568 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3570 s2
= fold_convert (pvoid_type_node
, s2
);
3572 n
= fold_convert (size_type_node
, n
);
3574 tmp
= build_call_expr_loc (input_location
,
3575 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3578 return fold_convert (integer_type_node
, tmp
);
3581 /* Compare two strings. If they are all single characters, the result is the
3582 subtraction of them. Otherwise, we build a library call. */
3585 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3586 enum tree_code code
)
3592 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3593 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3595 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3596 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3598 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3600 /* Deal with single character specially. */
3601 sc1
= fold_convert (integer_type_node
, sc1
);
3602 sc2
= fold_convert (integer_type_node
, sc2
);
3603 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3607 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3609 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3611 /* If one string is a string literal with LEN_TRIM longer
3612 than the length of the second string, the strings
3614 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3615 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3616 return integer_one_node
;
3617 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3618 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3619 return integer_one_node
;
3622 /* We can compare via memcpy if the strings are known to be equal
3623 in length and they are
3625 - kind=4 and the comparison is for (in)equality. */
3627 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3628 && tree_int_cst_equal (len1
, len2
)
3629 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3634 chartype
= gfc_get_char_type (kind
);
3635 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3636 fold_convert (TREE_TYPE(len1
),
3637 TYPE_SIZE_UNIT(chartype
)),
3639 return build_memcmp_call (str1
, str2
, tmp
);
3642 /* Build a call for the comparison. */
3644 fndecl
= gfor_fndecl_compare_string
;
3646 fndecl
= gfor_fndecl_compare_string_char4
;
3650 return build_call_expr_loc (input_location
, fndecl
, 4,
3651 len1
, str1
, len2
, str2
);
3655 /* Return the backend_decl for a procedure pointer component. */
3658 get_proc_ptr_comp (gfc_expr
*e
)
3664 gfc_init_se (&comp_se
, NULL
);
3665 e2
= gfc_copy_expr (e
);
3666 /* We have to restore the expr type later so that gfc_free_expr frees
3667 the exact same thing that was allocated.
3668 TODO: This is ugly. */
3669 old_type
= e2
->expr_type
;
3670 e2
->expr_type
= EXPR_VARIABLE
;
3671 gfc_conv_expr (&comp_se
, e2
);
3672 e2
->expr_type
= old_type
;
3674 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3678 /* Convert a typebound function reference from a class object. */
3680 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3685 if (!VAR_P (base_object
))
3687 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3688 gfc_add_modify (&se
->pre
, var
, base_object
);
3690 se
->expr
= gfc_class_vptr_get (base_object
);
3691 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3693 while (ref
&& ref
->next
)
3695 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3696 if (ref
->u
.c
.sym
->attr
.extension
)
3697 conv_parent_component_references (se
, ref
);
3698 gfc_conv_component_ref (se
, ref
);
3699 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3704 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3708 if (gfc_is_proc_ptr_comp (expr
))
3709 tmp
= get_proc_ptr_comp (expr
);
3710 else if (sym
->attr
.dummy
)
3712 tmp
= gfc_get_symbol_decl (sym
);
3713 if (sym
->attr
.proc_pointer
)
3714 tmp
= build_fold_indirect_ref_loc (input_location
,
3716 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3717 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3721 if (!sym
->backend_decl
)
3722 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3724 TREE_USED (sym
->backend_decl
) = 1;
3726 tmp
= sym
->backend_decl
;
3728 if (sym
->attr
.cray_pointee
)
3730 /* TODO - make the cray pointee a pointer to a procedure,
3731 assign the pointer to it and use it for the call. This
3733 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3734 gfc_get_symbol_decl (sym
->cp_pointer
));
3735 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3738 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3740 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3741 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3748 /* Initialize MAPPING. */
3751 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3753 mapping
->syms
= NULL
;
3754 mapping
->charlens
= NULL
;
3758 /* Free all memory held by MAPPING (but not MAPPING itself). */
3761 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3763 gfc_interface_sym_mapping
*sym
;
3764 gfc_interface_sym_mapping
*nextsym
;
3766 gfc_charlen
*nextcl
;
3768 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3770 nextsym
= sym
->next
;
3771 sym
->new_sym
->n
.sym
->formal
= NULL
;
3772 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3773 gfc_free_expr (sym
->expr
);
3774 free (sym
->new_sym
);
3777 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3780 gfc_free_expr (cl
->length
);
3786 /* Return a copy of gfc_charlen CL. Add the returned structure to
3787 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3789 static gfc_charlen
*
3790 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3793 gfc_charlen
*new_charlen
;
3795 new_charlen
= gfc_get_charlen ();
3796 new_charlen
->next
= mapping
->charlens
;
3797 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3799 mapping
->charlens
= new_charlen
;
3804 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3805 array variable that can be used as the actual argument for dummy
3806 argument SYM. Add any initialization code to BLOCK. PACKED is as
3807 for gfc_get_nodesc_array_type and DATA points to the first element
3808 in the passed array. */
3811 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3812 gfc_packed packed
, tree data
)
3817 type
= gfc_typenode_for_spec (&sym
->ts
);
3818 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3819 !sym
->attr
.target
&& !sym
->attr
.pointer
3820 && !sym
->attr
.proc_pointer
);
3822 var
= gfc_create_var (type
, "ifm");
3823 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3829 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3830 and offset of descriptorless array type TYPE given that it has the same
3831 size as DESC. Add any set-up code to BLOCK. */
3834 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3841 offset
= gfc_index_zero_node
;
3842 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3844 dim
= gfc_rank_cst
[n
];
3845 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3846 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3848 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3849 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3850 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3851 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3853 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3855 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3856 gfc_array_index_type
,
3857 gfc_conv_descriptor_ubound_get (desc
, dim
),
3858 gfc_conv_descriptor_lbound_get (desc
, dim
));
3859 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3860 gfc_array_index_type
,
3861 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3862 tmp
= gfc_evaluate_now (tmp
, block
);
3863 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3865 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3866 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3867 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3868 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3869 gfc_array_index_type
, offset
, tmp
);
3871 offset
= gfc_evaluate_now (offset
, block
);
3872 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3876 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3877 in SE. The caller may still use se->expr and se->string_length after
3878 calling this function. */
3881 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3882 gfc_symbol
* sym
, gfc_se
* se
,
3885 gfc_interface_sym_mapping
*sm
;
3889 gfc_symbol
*new_sym
;
3891 gfc_symtree
*new_symtree
;
3893 /* Create a new symbol to represent the actual argument. */
3894 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3895 new_sym
->ts
= sym
->ts
;
3896 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3897 new_sym
->attr
.referenced
= 1;
3898 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3899 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3900 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3901 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3902 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3903 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3904 new_sym
->attr
.function
= sym
->attr
.function
;
3906 /* Ensure that the interface is available and that
3907 descriptors are passed for array actual arguments. */
3908 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3910 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3911 new_sym
->attr
.always_explicit
3912 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3915 /* Create a fake symtree for it. */
3917 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3918 new_symtree
->n
.sym
= new_sym
;
3919 gcc_assert (new_symtree
== root
);
3921 /* Create a dummy->actual mapping. */
3922 sm
= XCNEW (gfc_interface_sym_mapping
);
3923 sm
->next
= mapping
->syms
;
3925 sm
->new_sym
= new_symtree
;
3926 sm
->expr
= gfc_copy_expr (expr
);
3929 /* Stabilize the argument's value. */
3930 if (!sym
->attr
.function
&& se
)
3931 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3933 if (sym
->ts
.type
== BT_CHARACTER
)
3935 /* Create a copy of the dummy argument's length. */
3936 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3937 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3939 /* If the length is specified as "*", record the length that
3940 the caller is passing. We should use the callee's length
3941 in all other cases. */
3942 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3944 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3945 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3952 /* Use the passed value as-is if the argument is a function. */
3953 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3956 /* If the argument is a pass-by-value scalar, use the value as is. */
3957 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3960 /* If the argument is either a string or a pointer to a string,
3961 convert it to a boundless character type. */
3962 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3964 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3965 tmp
= build_pointer_type (tmp
);
3966 if (sym
->attr
.pointer
)
3967 value
= build_fold_indirect_ref_loc (input_location
,
3971 value
= fold_convert (tmp
, value
);
3974 /* If the argument is a scalar, a pointer to an array or an allocatable,
3976 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3977 value
= build_fold_indirect_ref_loc (input_location
,
3980 /* For character(*), use the actual argument's descriptor. */
3981 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3982 value
= build_fold_indirect_ref_loc (input_location
,
3985 /* If the argument is an array descriptor, use it to determine
3986 information about the actual argument's shape. */
3987 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3988 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3990 /* Get the actual argument's descriptor. */
3991 desc
= build_fold_indirect_ref_loc (input_location
,
3994 /* Create the replacement variable. */
3995 tmp
= gfc_conv_descriptor_data_get (desc
);
3996 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3999 /* Use DESC to work out the upper bounds, strides and offset. */
4000 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4003 /* Otherwise we have a packed array. */
4004 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4005 PACKED_FULL
, se
->expr
);
4007 new_sym
->backend_decl
= value
;
4011 /* Called once all dummy argument mappings have been added to MAPPING,
4012 but before the mapping is used to evaluate expressions. Pre-evaluate
4013 the length of each argument, adding any initialization code to PRE and
4014 any finalization code to POST. */
4017 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4018 stmtblock_t
* pre
, stmtblock_t
* post
)
4020 gfc_interface_sym_mapping
*sym
;
4024 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4025 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4026 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4028 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4029 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4030 gfc_init_se (&se
, NULL
);
4031 gfc_conv_expr (&se
, expr
);
4032 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4033 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4034 gfc_add_block_to_block (pre
, &se
.pre
);
4035 gfc_add_block_to_block (post
, &se
.post
);
4037 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4042 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4046 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4047 gfc_constructor_base base
)
4050 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4052 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4055 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4056 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4057 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4063 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4067 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4072 for (; ref
; ref
= ref
->next
)
4076 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4078 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4079 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4080 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4088 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4089 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4095 /* Convert intrinsic function calls into result expressions. */
4098 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4106 arg1
= expr
->value
.function
.actual
->expr
;
4107 if (expr
->value
.function
.actual
->next
)
4108 arg2
= expr
->value
.function
.actual
->next
->expr
;
4112 sym
= arg1
->symtree
->n
.sym
;
4114 if (sym
->attr
.dummy
)
4119 switch (expr
->value
.function
.isym
->id
)
4122 /* TODO figure out why this condition is necessary. */
4123 if (sym
->attr
.function
4124 && (arg1
->ts
.u
.cl
->length
== NULL
4125 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4126 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4129 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4132 case GFC_ISYM_LEN_TRIM
:
4133 new_expr
= gfc_copy_expr (arg1
);
4134 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4139 gfc_replace_expr (arg1
, new_expr
);
4143 if (!sym
->as
|| sym
->as
->rank
== 0)
4146 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4148 dup
= mpz_get_si (arg2
->value
.integer
);
4153 dup
= sym
->as
->rank
;
4157 for (; d
< dup
; d
++)
4161 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4163 gfc_free_expr (new_expr
);
4167 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4168 gfc_get_int_expr (gfc_default_integer_kind
,
4170 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4172 new_expr
= gfc_multiply (new_expr
, tmp
);
4178 case GFC_ISYM_LBOUND
:
4179 case GFC_ISYM_UBOUND
:
4180 /* TODO These implementations of lbound and ubound do not limit if
4181 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4183 if (!sym
->as
|| sym
->as
->rank
== 0)
4186 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4187 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4191 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4193 if (sym
->as
->lower
[d
])
4194 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4198 if (sym
->as
->upper
[d
])
4199 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4207 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4211 gfc_replace_expr (expr
, new_expr
);
4217 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4218 gfc_interface_mapping
* mapping
)
4220 gfc_formal_arglist
*f
;
4221 gfc_actual_arglist
*actual
;
4223 actual
= expr
->value
.function
.actual
;
4224 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4226 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4231 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4234 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4239 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4241 for (d
= 0; d
< as
->rank
; d
++)
4243 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4244 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4247 expr
->value
.function
.esym
->as
= as
;
4250 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4252 expr
->value
.function
.esym
->ts
.u
.cl
->length
4253 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4255 gfc_apply_interface_mapping_to_expr (mapping
,
4256 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4261 /* EXPR is a copy of an expression that appeared in the interface
4262 associated with MAPPING. Walk it recursively looking for references to
4263 dummy arguments that MAPPING maps to actual arguments. Replace each such
4264 reference with a reference to the associated actual argument. */
4267 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4270 gfc_interface_sym_mapping
*sym
;
4271 gfc_actual_arglist
*actual
;
4276 /* Copying an expression does not copy its length, so do that here. */
4277 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4279 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4280 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4283 /* Apply the mapping to any references. */
4284 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4286 /* ...and to the expression's symbol, if it has one. */
4287 /* TODO Find out why the condition on expr->symtree had to be moved into
4288 the loop rather than being outside it, as originally. */
4289 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4290 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4292 if (sym
->new_sym
->n
.sym
->backend_decl
)
4293 expr
->symtree
= sym
->new_sym
;
4295 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4298 /* ...and to subexpressions in expr->value. */
4299 switch (expr
->expr_type
)
4304 case EXPR_SUBSTRING
:
4308 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4309 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4313 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4314 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4316 if (expr
->value
.function
.esym
== NULL
4317 && expr
->value
.function
.isym
!= NULL
4318 && expr
->value
.function
.actual
->expr
->symtree
4319 && gfc_map_intrinsic_function (expr
, mapping
))
4322 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4323 if (sym
->old
== expr
->value
.function
.esym
)
4325 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4326 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4327 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4332 case EXPR_STRUCTURE
:
4333 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4346 /* Evaluate interface expression EXPR using MAPPING. Store the result
4350 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4351 gfc_se
* se
, gfc_expr
* expr
)
4353 expr
= gfc_copy_expr (expr
);
4354 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4355 gfc_conv_expr (se
, expr
);
4356 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4357 gfc_free_expr (expr
);
4361 /* Returns a reference to a temporary array into which a component of
4362 an actual argument derived type array is copied and then returned
4363 after the function call. */
4365 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4366 sym_intent intent
, bool formal_ptr
)
4374 gfc_array_info
*info
;
4384 gfc_init_se (&lse
, NULL
);
4385 gfc_init_se (&rse
, NULL
);
4387 /* Walk the argument expression. */
4388 rss
= gfc_walk_expr (expr
);
4390 gcc_assert (rss
!= gfc_ss_terminator
);
4392 /* Initialize the scalarizer. */
4393 gfc_init_loopinfo (&loop
);
4394 gfc_add_ss_to_loop (&loop
, rss
);
4396 /* Calculate the bounds of the scalarization. */
4397 gfc_conv_ss_startstride (&loop
);
4399 /* Build an ss for the temporary. */
4400 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4401 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4403 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4404 if (GFC_ARRAY_TYPE_P (base_type
)
4405 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4406 base_type
= gfc_get_element_type (base_type
);
4408 if (expr
->ts
.type
== BT_CLASS
)
4409 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4411 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4412 ? expr
->ts
.u
.cl
->backend_decl
4416 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4418 /* Associate the SS with the loop. */
4419 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4421 /* Setup the scalarizing loops. */
4422 gfc_conv_loop_setup (&loop
, &expr
->where
);
4424 /* Pass the temporary descriptor back to the caller. */
4425 info
= &loop
.temp_ss
->info
->data
.array
;
4426 parmse
->expr
= info
->descriptor
;
4428 /* Setup the gfc_se structures. */
4429 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4430 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4433 lse
.ss
= loop
.temp_ss
;
4434 gfc_mark_ss_chain_used (rss
, 1);
4435 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4437 /* Start the scalarized loop body. */
4438 gfc_start_scalarized_body (&loop
, &body
);
4440 /* Translate the expression. */
4441 gfc_conv_expr (&rse
, expr
);
4443 /* Reset the offset for the function call since the loop
4444 is zero based on the data pointer. Note that the temp
4445 comes first in the loop chain since it is added second. */
4446 if (gfc_is_class_array_function (expr
))
4448 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4449 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4450 gfc_index_zero_node
);
4453 gfc_conv_tmp_array_ref (&lse
);
4455 if (intent
!= INTENT_OUT
)
4457 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4458 gfc_add_expr_to_block (&body
, tmp
);
4459 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4460 gfc_trans_scalarizing_loops (&loop
, &body
);
4464 /* Make sure that the temporary declaration survives by merging
4465 all the loop declarations into the current context. */
4466 for (n
= 0; n
< loop
.dimen
; n
++)
4468 gfc_merge_block_scope (&body
);
4469 body
= loop
.code
[loop
.order
[n
]];
4471 gfc_merge_block_scope (&body
);
4474 /* Add the post block after the second loop, so that any
4475 freeing of allocated memory is done at the right time. */
4476 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4478 /**********Copy the temporary back again.*********/
4480 gfc_init_se (&lse
, NULL
);
4481 gfc_init_se (&rse
, NULL
);
4483 /* Walk the argument expression. */
4484 lss
= gfc_walk_expr (expr
);
4485 rse
.ss
= loop
.temp_ss
;
4488 /* Initialize the scalarizer. */
4489 gfc_init_loopinfo (&loop2
);
4490 gfc_add_ss_to_loop (&loop2
, lss
);
4492 dimen
= rse
.ss
->dimen
;
4494 /* Skip the write-out loop for this case. */
4495 if (gfc_is_class_array_function (expr
))
4496 goto class_array_fcn
;
4498 /* Calculate the bounds of the scalarization. */
4499 gfc_conv_ss_startstride (&loop2
);
4501 /* Setup the scalarizing loops. */
4502 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4504 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4505 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4507 gfc_mark_ss_chain_used (lss
, 1);
4508 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4510 /* Declare the variable to hold the temporary offset and start the
4511 scalarized loop body. */
4512 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4513 gfc_start_scalarized_body (&loop2
, &body
);
4515 /* Build the offsets for the temporary from the loop variables. The
4516 temporary array has lbounds of zero and strides of one in all
4517 dimensions, so this is very simple. The offset is only computed
4518 outside the innermost loop, so the overall transfer could be
4519 optimized further. */
4520 info
= &rse
.ss
->info
->data
.array
;
4522 tmp_index
= gfc_index_zero_node
;
4523 for (n
= dimen
- 1; n
> 0; n
--)
4526 tmp
= rse
.loop
->loopvar
[n
];
4527 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4528 tmp
, rse
.loop
->from
[n
]);
4529 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4532 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4533 gfc_array_index_type
,
4534 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4535 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4536 gfc_array_index_type
,
4537 tmp_str
, gfc_index_one_node
);
4539 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4540 gfc_array_index_type
, tmp
, tmp_str
);
4543 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4544 gfc_array_index_type
,
4545 tmp_index
, rse
.loop
->from
[0]);
4546 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4548 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4549 gfc_array_index_type
,
4550 rse
.loop
->loopvar
[0], offset
);
4552 /* Now use the offset for the reference. */
4553 tmp
= build_fold_indirect_ref_loc (input_location
,
4555 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4557 if (expr
->ts
.type
== BT_CHARACTER
)
4558 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4560 gfc_conv_expr (&lse
, expr
);
4562 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4564 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4565 gfc_add_expr_to_block (&body
, tmp
);
4567 /* Generate the copying loops. */
4568 gfc_trans_scalarizing_loops (&loop2
, &body
);
4570 /* Wrap the whole thing up by adding the second loop to the post-block
4571 and following it by the post-block of the first loop. In this way,
4572 if the temporary needs freeing, it is done after use! */
4573 if (intent
!= INTENT_IN
)
4575 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4576 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4581 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4583 gfc_cleanup_loop (&loop
);
4584 gfc_cleanup_loop (&loop2
);
4586 /* Pass the string length to the argument expression. */
4587 if (expr
->ts
.type
== BT_CHARACTER
)
4588 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4590 /* Determine the offset for pointer formal arguments and set the
4594 size
= gfc_index_one_node
;
4595 offset
= gfc_index_zero_node
;
4596 for (n
= 0; n
< dimen
; n
++)
4598 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4600 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4601 gfc_array_index_type
, tmp
,
4602 gfc_index_one_node
);
4603 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4607 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4610 gfc_index_one_node
);
4611 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4612 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4613 gfc_array_index_type
,
4615 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4616 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4617 gfc_array_index_type
,
4618 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4619 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4620 gfc_array_index_type
,
4621 tmp
, gfc_index_one_node
);
4622 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4623 gfc_array_index_type
, size
, tmp
);
4626 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4630 /* We want either the address for the data or the address of the descriptor,
4631 depending on the mode of passing array arguments. */
4633 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4635 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4641 /* Generate the code for argument list functions. */
4644 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4646 /* Pass by value for g77 %VAL(arg), pass the address
4647 indirectly for %LOC, else by reference. Thus %REF
4648 is a "do-nothing" and %LOC is the same as an F95
4650 if (strncmp (name
, "%VAL", 4) == 0)
4651 gfc_conv_expr (se
, expr
);
4652 else if (strncmp (name
, "%LOC", 4) == 0)
4654 gfc_conv_expr_reference (se
, expr
);
4655 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4657 else if (strncmp (name
, "%REF", 4) == 0)
4658 gfc_conv_expr_reference (se
, expr
);
4660 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4664 /* This function tells whether the middle-end representation of the expression
4665 E given as input may point to data otherwise accessible through a variable
4667 It is assumed that the only expressions that may alias are variables,
4668 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4670 This function is used to decide whether freeing an expression's allocatable
4671 components is safe or should be avoided.
4673 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4674 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4675 is necessary because for array constructors, aliasing depends on how
4677 - If E is an array constructor used as argument to an elemental procedure,
4678 the array, which is generated through shallow copy by the scalarizer,
4679 is used directly and can alias the expressions it was copied from.
4680 - If E is an array constructor used as argument to a non-elemental
4681 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4682 the array as in the previous case, but then that array is used
4683 to initialize a new descriptor through deep copy. There is no alias
4684 possible in that case.
4685 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4689 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4693 if (e
->expr_type
== EXPR_VARIABLE
)
4695 else if (e
->expr_type
== EXPR_FUNCTION
)
4697 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4699 if (proc_ifc
->result
!= NULL
4700 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4701 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4702 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4703 || proc_ifc
->result
->attr
.pointer
))
4708 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4711 for (c
= gfc_constructor_first (e
->value
.constructor
);
4712 c
; c
= gfc_constructor_next (c
))
4714 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4721 /* Generate code for a procedure call. Note can return se->post != NULL.
4722 If se->direct_byref is set then se->expr contains the return parameter.
4723 Return nonzero, if the call has alternate specifiers.
4724 'expr' is only needed for procedure pointer components. */
4727 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4728 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4729 vec
<tree
, va_gc
> *append_args
)
4731 gfc_interface_mapping mapping
;
4732 vec
<tree
, va_gc
> *arglist
;
4733 vec
<tree
, va_gc
> *retargs
;
4737 gfc_array_info
*info
;
4744 vec
<tree
, va_gc
> *stringargs
;
4745 vec
<tree
, va_gc
> *optionalargs
;
4747 gfc_formal_arglist
*formal
;
4748 gfc_actual_arglist
*arg
;
4749 int has_alternate_specifier
= 0;
4750 bool need_interface_mapping
;
4758 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4759 gfc_component
*comp
= NULL
;
4766 optionalargs
= NULL
;
4771 comp
= gfc_get_proc_ptr_comp (expr
);
4773 bool elemental_proc
= (comp
4774 && comp
->ts
.interface
4775 && comp
->ts
.interface
->attr
.elemental
)
4776 || (comp
&& comp
->attr
.elemental
)
4777 || sym
->attr
.elemental
;
4781 if (!elemental_proc
)
4783 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4784 if (se
->ss
->info
->useflags
)
4786 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4787 && sym
->result
->attr
.dimension
)
4788 || (comp
&& comp
->attr
.dimension
)
4789 || gfc_is_class_array_function (expr
));
4790 gcc_assert (se
->loop
!= NULL
);
4791 /* Access the previously obtained result. */
4792 gfc_conv_tmp_array_ref (se
);
4796 info
= &se
->ss
->info
->data
.array
;
4801 gfc_init_block (&post
);
4802 gfc_init_interface_mapping (&mapping
);
4805 formal
= gfc_sym_get_dummy_args (sym
);
4806 need_interface_mapping
= sym
->attr
.dimension
||
4807 (sym
->ts
.type
== BT_CHARACTER
4808 && sym
->ts
.u
.cl
->length
4809 && sym
->ts
.u
.cl
->length
->expr_type
4814 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4815 need_interface_mapping
= comp
->attr
.dimension
||
4816 (comp
->ts
.type
== BT_CHARACTER
4817 && comp
->ts
.u
.cl
->length
4818 && comp
->ts
.u
.cl
->length
->expr_type
4822 base_object
= NULL_TREE
;
4823 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4824 is the third and fourth argument to such a function call a value
4825 denoting the number of elements to copy (i.e., most of the time the
4826 length of a deferred length string). */
4827 ulim_copy
= (formal
== NULL
)
4828 && UNLIMITED_POLY (sym
)
4829 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4831 /* Evaluate the arguments. */
4832 for (arg
= args
, argc
= 0; arg
!= NULL
;
4833 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4836 fsym
= formal
? formal
->sym
: NULL
;
4837 parm_kind
= MISSING
;
4839 /* If the procedure requires an explicit interface, the actual
4840 argument is passed according to the corresponding formal
4841 argument. If the corresponding formal argument is a POINTER,
4842 ALLOCATABLE or assumed shape, we do not use g77's calling
4843 convention, and pass the address of the array descriptor
4844 instead. Otherwise we use g77's calling convention, in other words
4845 pass the array data pointer without descriptor. */
4846 bool nodesc_arg
= fsym
!= NULL
4847 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4849 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4850 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4852 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4854 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4856 /* Class array expressions are sometimes coming completely unadorned
4857 with either arrayspec or _data component. Correct that here.
4858 OOP-TODO: Move this to the frontend. */
4859 if (e
&& e
->expr_type
== EXPR_VARIABLE
4861 && e
->ts
.type
== BT_CLASS
4862 && (CLASS_DATA (e
)->attr
.codimension
4863 || CLASS_DATA (e
)->attr
.dimension
))
4865 gfc_typespec temp_ts
= e
->ts
;
4866 gfc_add_class_array_ref (e
);
4872 if (se
->ignore_optional
)
4874 /* Some intrinsics have already been resolved to the correct
4878 else if (arg
->label
)
4880 has_alternate_specifier
= 1;
4885 gfc_init_se (&parmse
, NULL
);
4887 /* For scalar arguments with VALUE attribute which are passed by
4888 value, pass "0" and a hidden argument gives the optional
4890 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4891 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4892 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4894 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4896 vec_safe_push (optionalargs
, boolean_false_node
);
4900 /* Pass a NULL pointer for an absent arg. */
4901 parmse
.expr
= null_pointer_node
;
4902 if (arg
->missing_arg_type
== BT_CHARACTER
)
4903 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4908 else if (arg
->expr
->expr_type
== EXPR_NULL
4909 && fsym
&& !fsym
->attr
.pointer
4910 && (fsym
->ts
.type
!= BT_CLASS
4911 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4913 /* Pass a NULL pointer to denote an absent arg. */
4914 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4915 && (fsym
->ts
.type
!= BT_CLASS
4916 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4917 gfc_init_se (&parmse
, NULL
);
4918 parmse
.expr
= null_pointer_node
;
4919 if (arg
->missing_arg_type
== BT_CHARACTER
)
4920 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4922 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4923 && e
->ts
.type
== BT_DERIVED
)
4925 /* The derived type needs to be converted to a temporary
4927 gfc_init_se (&parmse
, se
);
4928 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4930 && e
->expr_type
== EXPR_VARIABLE
4931 && e
->symtree
->n
.sym
->attr
.optional
,
4932 CLASS_DATA (fsym
)->attr
.class_pointer
4933 || CLASS_DATA (fsym
)->attr
.allocatable
);
4935 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4937 /* The intrinsic type needs to be converted to a temporary
4938 CLASS object for the unlimited polymorphic formal. */
4939 gfc_init_se (&parmse
, se
);
4940 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4942 else if (se
->ss
&& se
->ss
->info
->useflags
)
4948 /* An elemental function inside a scalarized loop. */
4949 gfc_init_se (&parmse
, se
);
4950 parm_kind
= ELEMENTAL
;
4952 /* When no fsym is present, ulim_copy is set and this is a third or
4953 fourth argument, use call-by-value instead of by reference to
4954 hand the length properties to the copy routine (i.e., most of the
4955 time this will be a call to a __copy_character_* routine where the
4956 third and fourth arguments are the lengths of a deferred length
4958 if ((fsym
&& fsym
->attr
.value
)
4959 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4960 gfc_conv_expr (&parmse
, e
);
4962 gfc_conv_expr_reference (&parmse
, e
);
4964 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4965 && e
->expr_type
== EXPR_FUNCTION
)
4966 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4969 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4970 && gfc_is_class_container_ref (e
))
4972 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4974 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4975 && e
->symtree
->n
.sym
->attr
.optional
)
4977 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4978 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4979 TREE_TYPE (parmse
.expr
),
4981 fold_convert (TREE_TYPE (parmse
.expr
),
4982 null_pointer_node
));
4986 /* If we are passing an absent array as optional dummy to an
4987 elemental procedure, make sure that we pass NULL when the data
4988 pointer is NULL. We need this extra conditional because of
4989 scalarization which passes arrays elements to the procedure,
4990 ignoring the fact that the array can be absent/unallocated/... */
4991 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4993 tree descriptor_data
;
4995 descriptor_data
= ss
->info
->data
.array
.data
;
4996 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
4998 fold_convert (TREE_TYPE (descriptor_data
),
4999 null_pointer_node
));
5001 = fold_build3_loc (input_location
, COND_EXPR
,
5002 TREE_TYPE (parmse
.expr
),
5003 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5004 fold_convert (TREE_TYPE (parmse
.expr
),
5009 /* The scalarizer does not repackage the reference to a class
5010 array - instead it returns a pointer to the data element. */
5011 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5012 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5013 fsym
->attr
.intent
!= INTENT_IN
5014 && (CLASS_DATA (fsym
)->attr
.class_pointer
5015 || CLASS_DATA (fsym
)->attr
.allocatable
),
5017 && e
->expr_type
== EXPR_VARIABLE
5018 && e
->symtree
->n
.sym
->attr
.optional
,
5019 CLASS_DATA (fsym
)->attr
.class_pointer
5020 || CLASS_DATA (fsym
)->attr
.allocatable
);
5027 gfc_init_se (&parmse
, NULL
);
5029 /* Check whether the expression is a scalar or not; we cannot use
5030 e->rank as it can be nonzero for functions arguments. */
5031 argss
= gfc_walk_expr (e
);
5032 scalar
= argss
== gfc_ss_terminator
;
5034 gfc_free_ss_chain (argss
);
5036 /* Special handling for passing scalar polymorphic coarrays;
5037 otherwise one passes "class->_data.data" instead of "&class". */
5038 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5039 && fsym
&& fsym
->ts
.type
== BT_CLASS
5040 && CLASS_DATA (fsym
)->attr
.codimension
5041 && !CLASS_DATA (fsym
)->attr
.dimension
)
5043 gfc_add_class_array_ref (e
);
5044 parmse
.want_coarray
= 1;
5048 /* A scalar or transformational function. */
5051 if (e
->expr_type
== EXPR_VARIABLE
5052 && e
->symtree
->n
.sym
->attr
.cray_pointee
5053 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5055 /* The Cray pointer needs to be converted to a pointer to
5056 a type given by the expression. */
5057 gfc_conv_expr (&parmse
, e
);
5058 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5059 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5060 parmse
.expr
= convert (type
, tmp
);
5062 else if (fsym
&& fsym
->attr
.value
)
5064 if (fsym
->ts
.type
== BT_CHARACTER
5065 && fsym
->ts
.is_c_interop
5066 && fsym
->ns
->proc_name
!= NULL
5067 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5070 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5071 if (parmse
.expr
== NULL
)
5072 gfc_conv_expr (&parmse
, e
);
5076 gfc_conv_expr (&parmse
, e
);
5077 if (fsym
->attr
.optional
5078 && fsym
->ts
.type
!= BT_CLASS
5079 && fsym
->ts
.type
!= BT_DERIVED
)
5081 if (e
->expr_type
!= EXPR_VARIABLE
5082 || !e
->symtree
->n
.sym
->attr
.optional
5084 vec_safe_push (optionalargs
, boolean_true_node
);
5087 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5088 if (!e
->symtree
->n
.sym
->attr
.value
)
5090 = fold_build3_loc (input_location
, COND_EXPR
,
5091 TREE_TYPE (parmse
.expr
),
5093 fold_convert (TREE_TYPE (parmse
.expr
),
5094 integer_zero_node
));
5096 vec_safe_push (optionalargs
, tmp
);
5101 else if (arg
->name
&& arg
->name
[0] == '%')
5102 /* Argument list functions %VAL, %LOC and %REF are signalled
5103 through arg->name. */
5104 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5105 else if ((e
->expr_type
== EXPR_FUNCTION
)
5106 && ((e
->value
.function
.esym
5107 && e
->value
.function
.esym
->result
->attr
.pointer
)
5108 || (!e
->value
.function
.esym
5109 && e
->symtree
->n
.sym
->attr
.pointer
))
5110 && fsym
&& fsym
->attr
.target
)
5112 gfc_conv_expr (&parmse
, e
);
5113 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5115 else if (e
->expr_type
== EXPR_FUNCTION
5116 && e
->symtree
->n
.sym
->result
5117 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5118 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5120 /* Functions returning procedure pointers. */
5121 gfc_conv_expr (&parmse
, e
);
5122 if (fsym
&& fsym
->attr
.proc_pointer
)
5123 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5127 if (e
->ts
.type
== BT_CLASS
&& fsym
5128 && fsym
->ts
.type
== BT_CLASS
5129 && (!CLASS_DATA (fsym
)->as
5130 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5131 && CLASS_DATA (e
)->attr
.codimension
)
5133 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5134 gcc_assert (!CLASS_DATA (fsym
)->as
);
5135 gfc_add_class_array_ref (e
);
5136 parmse
.want_coarray
= 1;
5137 gfc_conv_expr_reference (&parmse
, e
);
5138 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5140 && e
->expr_type
== EXPR_VARIABLE
);
5142 else if (e
->ts
.type
== BT_CLASS
&& fsym
5143 && fsym
->ts
.type
== BT_CLASS
5144 && !CLASS_DATA (fsym
)->as
5145 && !CLASS_DATA (e
)->as
5146 && strcmp (fsym
->ts
.u
.derived
->name
,
5147 e
->ts
.u
.derived
->name
))
5149 type
= gfc_typenode_for_spec (&fsym
->ts
);
5150 var
= gfc_create_var (type
, fsym
->name
);
5151 gfc_conv_expr (&parmse
, e
);
5152 if (fsym
->attr
.optional
5153 && e
->expr_type
== EXPR_VARIABLE
5154 && e
->symtree
->n
.sym
->attr
.optional
)
5158 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5159 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5160 logical_type_node
, tmp
,
5161 fold_convert (TREE_TYPE (tmp
),
5162 null_pointer_node
));
5163 gfc_start_block (&block
);
5164 gfc_add_modify (&block
, var
,
5165 fold_build1_loc (input_location
,
5167 type
, parmse
.expr
));
5168 gfc_add_expr_to_block (&parmse
.pre
,
5169 fold_build3_loc (input_location
,
5170 COND_EXPR
, void_type_node
,
5171 cond
, gfc_finish_block (&block
),
5172 build_empty_stmt (input_location
)));
5173 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5174 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5175 TREE_TYPE (parmse
.expr
),
5177 fold_convert (TREE_TYPE (parmse
.expr
),
5178 null_pointer_node
));
5182 /* Since the internal representation of unlimited
5183 polymorphic expressions includes an extra field
5184 that other class objects do not, a cast to the
5185 formal type does not work. */
5186 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5190 /* Set the _data field. */
5191 tmp
= gfc_class_data_get (var
);
5192 efield
= fold_convert (TREE_TYPE (tmp
),
5193 gfc_class_data_get (parmse
.expr
));
5194 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5196 /* Set the _vptr field. */
5197 tmp
= gfc_class_vptr_get (var
);
5198 efield
= fold_convert (TREE_TYPE (tmp
),
5199 gfc_class_vptr_get (parmse
.expr
));
5200 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5202 /* Set the _len field. */
5203 tmp
= gfc_class_len_get (var
);
5204 gfc_add_modify (&parmse
.pre
, tmp
,
5205 build_int_cst (TREE_TYPE (tmp
), 0));
5209 tmp
= fold_build1_loc (input_location
,
5212 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5215 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5219 gfc_conv_expr_reference (&parmse
, e
);
5221 /* Catch base objects that are not variables. */
5222 if (e
->ts
.type
== BT_CLASS
5223 && e
->expr_type
!= EXPR_VARIABLE
5224 && expr
&& e
== expr
->base_expr
)
5225 base_object
= build_fold_indirect_ref_loc (input_location
,
5228 /* A class array element needs converting back to be a
5229 class object, if the formal argument is a class object. */
5230 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5231 && e
->ts
.type
== BT_CLASS
5232 && ((CLASS_DATA (fsym
)->as
5233 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5234 || CLASS_DATA (e
)->attr
.dimension
))
5235 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5236 fsym
->attr
.intent
!= INTENT_IN
5237 && (CLASS_DATA (fsym
)->attr
.class_pointer
5238 || CLASS_DATA (fsym
)->attr
.allocatable
),
5240 && e
->expr_type
== EXPR_VARIABLE
5241 && e
->symtree
->n
.sym
->attr
.optional
,
5242 CLASS_DATA (fsym
)->attr
.class_pointer
5243 || CLASS_DATA (fsym
)->attr
.allocatable
);
5245 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5246 allocated on entry, it must be deallocated. */
5247 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5248 && (fsym
->attr
.allocatable
5249 || (fsym
->ts
.type
== BT_CLASS
5250 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5255 gfc_init_block (&block
);
5257 if (e
->ts
.type
== BT_CLASS
)
5258 ptr
= gfc_class_data_get (ptr
);
5260 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5263 gfc_add_expr_to_block (&block
, tmp
);
5264 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5265 void_type_node
, ptr
,
5267 gfc_add_expr_to_block (&block
, tmp
);
5269 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5271 gfc_add_modify (&block
, ptr
,
5272 fold_convert (TREE_TYPE (ptr
),
5273 null_pointer_node
));
5274 gfc_add_expr_to_block (&block
, tmp
);
5276 else if (fsym
->ts
.type
== BT_CLASS
)
5279 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5280 tmp
= gfc_get_symbol_decl (vtab
);
5281 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5282 ptr
= gfc_class_vptr_get (parmse
.expr
);
5283 gfc_add_modify (&block
, ptr
,
5284 fold_convert (TREE_TYPE (ptr
), tmp
));
5285 gfc_add_expr_to_block (&block
, tmp
);
5288 if (fsym
->attr
.optional
5289 && e
->expr_type
== EXPR_VARIABLE
5290 && e
->symtree
->n
.sym
->attr
.optional
)
5292 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5294 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5295 gfc_finish_block (&block
),
5296 build_empty_stmt (input_location
));
5299 tmp
= gfc_finish_block (&block
);
5301 gfc_add_expr_to_block (&se
->pre
, tmp
);
5304 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5305 || fsym
->ts
.type
== BT_ASSUMED
)
5306 && e
->ts
.type
== BT_CLASS
5307 && !CLASS_DATA (e
)->attr
.dimension
5308 && !CLASS_DATA (e
)->attr
.codimension
)
5309 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5311 /* Wrap scalar variable in a descriptor. We need to convert
5312 the address of a pointer back to the pointer itself before,
5313 we can assign it to the data field. */
5315 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5316 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5319 if (TREE_CODE (tmp
) == ADDR_EXPR
5320 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5321 tmp
= TREE_OPERAND (tmp
, 0);
5322 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5324 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5327 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5328 && ((fsym
->attr
.pointer
5329 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5330 || (fsym
->attr
.proc_pointer
5331 && !(e
->expr_type
== EXPR_VARIABLE
5332 && e
->symtree
->n
.sym
->attr
.dummy
))
5333 || (fsym
->attr
.proc_pointer
5334 && e
->expr_type
== EXPR_VARIABLE
5335 && gfc_is_proc_ptr_comp (e
))
5336 || (fsym
->attr
.allocatable
5337 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5339 /* Scalar pointer dummy args require an extra level of
5340 indirection. The null pointer already contains
5341 this level of indirection. */
5342 parm_kind
= SCALAR_POINTER
;
5343 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5347 else if (e
->ts
.type
== BT_CLASS
5348 && fsym
&& fsym
->ts
.type
== BT_CLASS
5349 && (CLASS_DATA (fsym
)->attr
.dimension
5350 || CLASS_DATA (fsym
)->attr
.codimension
))
5352 /* Pass a class array. */
5353 parmse
.use_offset
= 1;
5354 gfc_conv_expr_descriptor (&parmse
, e
);
5356 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5357 allocated on entry, it must be deallocated. */
5358 if (fsym
->attr
.intent
== INTENT_OUT
5359 && CLASS_DATA (fsym
)->attr
.allocatable
)
5364 gfc_init_block (&block
);
5366 ptr
= gfc_class_data_get (ptr
);
5368 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5369 NULL_TREE
, NULL_TREE
,
5371 GFC_CAF_COARRAY_NOCOARRAY
);
5372 gfc_add_expr_to_block (&block
, tmp
);
5373 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5374 void_type_node
, ptr
,
5376 gfc_add_expr_to_block (&block
, tmp
);
5377 gfc_reset_vptr (&block
, e
);
5379 if (fsym
->attr
.optional
5380 && e
->expr_type
== EXPR_VARIABLE
5382 || (e
->ref
->type
== REF_ARRAY
5383 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5384 && e
->symtree
->n
.sym
->attr
.optional
)
5386 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5388 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5389 gfc_finish_block (&block
),
5390 build_empty_stmt (input_location
));
5393 tmp
= gfc_finish_block (&block
);
5395 gfc_add_expr_to_block (&se
->pre
, tmp
);
5398 /* The conversion does not repackage the reference to a class
5399 array - _data descriptor. */
5400 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5401 fsym
->attr
.intent
!= INTENT_IN
5402 && (CLASS_DATA (fsym
)->attr
.class_pointer
5403 || CLASS_DATA (fsym
)->attr
.allocatable
),
5405 && e
->expr_type
== EXPR_VARIABLE
5406 && e
->symtree
->n
.sym
->attr
.optional
,
5407 CLASS_DATA (fsym
)->attr
.class_pointer
5408 || CLASS_DATA (fsym
)->attr
.allocatable
);
5412 /* If the argument is a function call that may not create
5413 a temporary for the result, we have to check that we
5414 can do it, i.e. that there is no alias between this
5415 argument and another one. */
5416 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5422 intent
= fsym
->attr
.intent
;
5424 intent
= INTENT_UNKNOWN
;
5426 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5428 parmse
.force_tmp
= 1;
5430 iarg
= e
->value
.function
.actual
->expr
;
5432 /* Temporary needed if aliasing due to host association. */
5433 if (sym
->attr
.contained
5435 && !sym
->attr
.implicit_pure
5436 && !sym
->attr
.use_assoc
5437 && iarg
->expr_type
== EXPR_VARIABLE
5438 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5439 parmse
.force_tmp
= 1;
5441 /* Ditto within module. */
5442 if (sym
->attr
.use_assoc
5444 && !sym
->attr
.implicit_pure
5445 && iarg
->expr_type
== EXPR_VARIABLE
5446 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5447 parmse
.force_tmp
= 1;
5450 if (e
->expr_type
== EXPR_VARIABLE
5451 && is_subref_array (e
)
5452 && !(fsym
&& fsym
->attr
.pointer
))
5453 /* The actual argument is a component reference to an
5454 array of derived types. In this case, the argument
5455 is converted to a temporary, which is passed and then
5456 written back after the procedure call. */
5457 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5458 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5459 fsym
&& fsym
->attr
.pointer
);
5460 else if (gfc_is_class_array_ref (e
, NULL
)
5461 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5462 /* The actual argument is a component reference to an
5463 array of derived types. In this case, the argument
5464 is converted to a temporary, which is passed and then
5465 written back after the procedure call.
5466 OOP-TODO: Insert code so that if the dynamic type is
5467 the same as the declared type, copy-in/copy-out does
5469 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5470 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5471 fsym
&& fsym
->attr
.pointer
);
5473 else if (gfc_is_class_array_function (e
)
5474 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5475 /* See previous comment. For function actual argument,
5476 the write out is not needed so the intent is set as
5479 e
->must_finalize
= 1;
5480 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5482 fsym
&& fsym
->attr
.pointer
);
5485 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5488 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5489 allocated on entry, it must be deallocated. */
5490 if (fsym
&& fsym
->attr
.allocatable
5491 && fsym
->attr
.intent
== INTENT_OUT
)
5493 if (fsym
->ts
.type
== BT_DERIVED
5494 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5496 // deallocate the components first
5497 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5498 parmse
.expr
, e
->rank
);
5499 if (tmp
!= NULL_TREE
)
5500 gfc_add_expr_to_block (&se
->pre
, tmp
);
5503 tmp
= build_fold_indirect_ref_loc (input_location
,
5505 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5506 tmp
= gfc_conv_descriptor_data_get (tmp
);
5507 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5508 NULL_TREE
, NULL_TREE
, true,
5510 GFC_CAF_COARRAY_NOCOARRAY
);
5511 if (fsym
->attr
.optional
5512 && e
->expr_type
== EXPR_VARIABLE
5513 && e
->symtree
->n
.sym
->attr
.optional
)
5514 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5516 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5517 tmp
, build_empty_stmt (input_location
));
5518 gfc_add_expr_to_block (&se
->pre
, tmp
);
5523 /* The case with fsym->attr.optional is that of a user subroutine
5524 with an interface indicating an optional argument. When we call
5525 an intrinsic subroutine, however, fsym is NULL, but we might still
5526 have an optional argument, so we proceed to the substitution
5528 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5530 /* If an optional argument is itself an optional dummy argument,
5531 check its presence and substitute a null if absent. This is
5532 only needed when passing an array to an elemental procedure
5533 as then array elements are accessed - or no NULL pointer is
5534 allowed and a "1" or "0" should be passed if not present.
5535 When passing a non-array-descriptor full array to a
5536 non-array-descriptor dummy, no check is needed. For
5537 array-descriptor actual to array-descriptor dummy, see
5538 PR 41911 for why a check has to be inserted.
5539 fsym == NULL is checked as intrinsics required the descriptor
5540 but do not always set fsym. */
5541 if (e
->expr_type
== EXPR_VARIABLE
5542 && e
->symtree
->n
.sym
->attr
.optional
5543 && ((e
->rank
!= 0 && elemental_proc
)
5544 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5548 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5549 || fsym
->as
->type
== AS_ASSUMED_RANK
5550 || fsym
->as
->type
== AS_DEFERRED
))))))
5551 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5552 e
->representation
.length
);
5557 /* Obtain the character length of an assumed character length
5558 length procedure from the typespec. */
5559 if (fsym
->ts
.type
== BT_CHARACTER
5560 && parmse
.string_length
== NULL_TREE
5561 && e
->ts
.type
== BT_PROCEDURE
5562 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5563 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5564 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5566 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5567 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5571 if (fsym
&& need_interface_mapping
&& e
)
5572 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5574 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5575 gfc_add_block_to_block (&post
, &parmse
.post
);
5577 /* Allocated allocatable components of derived types must be
5578 deallocated for non-variable scalars, array arguments to elemental
5579 procedures, and array arguments with descriptor to non-elemental
5580 procedures. As bounds information for descriptorless arrays is no
5581 longer available here, they are dealt with in trans-array.c
5582 (gfc_conv_array_parameter). */
5583 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5584 && e
->ts
.u
.derived
->attr
.alloc_comp
5585 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5586 && !expr_may_alias_variables (e
, elemental_proc
))
5589 /* It is known the e returns a structure type with at least one
5590 allocatable component. When e is a function, ensure that the
5591 function is called once only by using a temporary variable. */
5592 if (!DECL_P (parmse
.expr
))
5593 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5594 parmse
.expr
, &se
->pre
);
5596 if (fsym
&& fsym
->attr
.value
)
5599 tmp
= build_fold_indirect_ref_loc (input_location
,
5602 parm_rank
= e
->rank
;
5610 case (SCALAR_POINTER
):
5611 tmp
= build_fold_indirect_ref_loc (input_location
,
5616 if (e
->expr_type
== EXPR_OP
5617 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5618 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5621 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5622 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5624 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5627 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5629 /* The derived type is passed to gfc_deallocate_alloc_comp.
5630 Therefore, class actuals can handled correctly but derived
5631 types passed to class formals need the _data component. */
5632 tmp
= gfc_class_data_get (tmp
);
5633 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5634 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5637 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5639 gfc_prepend_expr_to_block (&post
, tmp
);
5642 /* Add argument checking of passing an unallocated/NULL actual to
5643 a nonallocatable/nonpointer dummy. */
5645 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5647 symbol_attribute attr
;
5651 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5652 attr
= gfc_expr_attr (e
);
5654 goto end_pointer_check
;
5656 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5657 allocatable to an optional dummy, cf. 12.5.2.12. */
5658 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5659 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5660 goto end_pointer_check
;
5664 /* If the actual argument is an optional pointer/allocatable and
5665 the formal argument takes an nonpointer optional value,
5666 it is invalid to pass a non-present argument on, even
5667 though there is no technical reason for this in gfortran.
5668 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5669 tree present
, null_ptr
, type
;
5671 if (attr
.allocatable
5672 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5673 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5674 "allocated or not present",
5675 e
->symtree
->n
.sym
->name
);
5676 else if (attr
.pointer
5677 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5678 msg
= xasprintf ("Pointer actual argument '%s' is not "
5679 "associated or not present",
5680 e
->symtree
->n
.sym
->name
);
5681 else if (attr
.proc_pointer
5682 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5683 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5684 "associated or not present",
5685 e
->symtree
->n
.sym
->name
);
5687 goto end_pointer_check
;
5689 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5690 type
= TREE_TYPE (present
);
5691 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5692 logical_type_node
, present
,
5694 null_pointer_node
));
5695 type
= TREE_TYPE (parmse
.expr
);
5696 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5697 logical_type_node
, parmse
.expr
,
5699 null_pointer_node
));
5700 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5701 logical_type_node
, present
, null_ptr
);
5705 if (attr
.allocatable
5706 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5707 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5708 "allocated", e
->symtree
->n
.sym
->name
);
5709 else if (attr
.pointer
5710 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5711 msg
= xasprintf ("Pointer actual argument '%s' is not "
5712 "associated", e
->symtree
->n
.sym
->name
);
5713 else if (attr
.proc_pointer
5714 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5715 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5716 "associated", e
->symtree
->n
.sym
->name
);
5718 goto end_pointer_check
;
5722 /* If the argument is passed by value, we need to strip the
5724 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5725 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5727 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5728 logical_type_node
, tmp
,
5729 fold_convert (TREE_TYPE (tmp
),
5730 null_pointer_node
));
5733 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5739 /* Deferred length dummies pass the character length by reference
5740 so that the value can be returned. */
5741 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5743 if (INDIRECT_REF_P (parmse
.string_length
))
5744 /* In chains of functions/procedure calls the string_length already
5745 is a pointer to the variable holding the length. Therefore
5746 remove the deref on call. */
5747 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5750 tmp
= parmse
.string_length
;
5751 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5752 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5753 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5757 /* Character strings are passed as two parameters, a length and a
5758 pointer - except for Bind(c) which only passes the pointer.
5759 An unlimited polymorphic formal argument likewise does not
5761 if (parmse
.string_length
!= NULL_TREE
5762 && !sym
->attr
.is_bind_c
5763 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5764 vec_safe_push (stringargs
, parmse
.string_length
);
5766 /* When calling __copy for character expressions to unlimited
5767 polymorphic entities, the dst argument needs a string length. */
5768 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5769 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5770 && arg
->next
&& arg
->next
->expr
5771 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5772 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5773 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5774 vec_safe_push (stringargs
, parmse
.string_length
);
5776 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5777 pass the token and the offset as additional arguments. */
5778 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5779 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5780 && !fsym
->attr
.allocatable
)
5781 || (fsym
->ts
.type
== BT_CLASS
5782 && CLASS_DATA (fsym
)->attr
.codimension
5783 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5785 /* Token and offset. */
5786 vec_safe_push (stringargs
, null_pointer_node
);
5787 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5788 gcc_assert (fsym
->attr
.optional
);
5790 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5791 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5792 && !fsym
->attr
.allocatable
)
5793 || (fsym
->ts
.type
== BT_CLASS
5794 && CLASS_DATA (fsym
)->attr
.codimension
5795 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5797 tree caf_decl
, caf_type
;
5800 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5801 caf_type
= TREE_TYPE (caf_decl
);
5803 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5804 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5805 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5806 tmp
= gfc_conv_descriptor_token (caf_decl
);
5807 else if (DECL_LANG_SPECIFIC (caf_decl
)
5808 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5809 tmp
= GFC_DECL_TOKEN (caf_decl
);
5812 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5813 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5814 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5817 vec_safe_push (stringargs
, tmp
);
5819 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5820 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5821 offset
= build_int_cst (gfc_array_index_type
, 0);
5822 else if (DECL_LANG_SPECIFIC (caf_decl
)
5823 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5824 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5825 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5826 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5828 offset
= build_int_cst (gfc_array_index_type
, 0);
5830 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5831 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5834 gcc_assert (POINTER_TYPE_P (caf_type
));
5838 tmp2
= fsym
->ts
.type
== BT_CLASS
5839 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5840 if ((fsym
->ts
.type
!= BT_CLASS
5841 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5842 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5843 || (fsym
->ts
.type
== BT_CLASS
5844 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5845 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5847 if (fsym
->ts
.type
== BT_CLASS
)
5848 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5851 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5852 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5854 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5855 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5857 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5858 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5861 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5864 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5865 gfc_array_index_type
,
5866 fold_convert (gfc_array_index_type
, tmp2
),
5867 fold_convert (gfc_array_index_type
, tmp
));
5868 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5869 gfc_array_index_type
, offset
, tmp
);
5871 vec_safe_push (stringargs
, offset
);
5874 vec_safe_push (arglist
, parmse
.expr
);
5876 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5880 else if (sym
->ts
.type
== BT_CLASS
)
5881 ts
= CLASS_DATA (sym
)->ts
;
5885 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5886 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5887 else if (ts
.type
== BT_CHARACTER
)
5889 if (ts
.u
.cl
->length
== NULL
)
5891 /* Assumed character length results are not allowed by 5.1.1.5 of the
5892 standard and are trapped in resolve.c; except in the case of SPREAD
5893 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5894 we take the character length of the first argument for the result.
5895 For dummies, we have to look through the formal argument list for
5896 this function and use the character length found there.*/
5898 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5899 else if (!sym
->attr
.dummy
)
5900 cl
.backend_decl
= (*stringargs
)[0];
5903 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5904 for (; formal
; formal
= formal
->next
)
5905 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5906 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5908 len
= cl
.backend_decl
;
5914 /* Calculate the length of the returned string. */
5915 gfc_init_se (&parmse
, NULL
);
5916 if (need_interface_mapping
)
5917 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5919 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5920 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5921 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5923 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5924 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5925 gfc_charlen_type_node
, tmp
,
5926 build_int_cst (gfc_charlen_type_node
, 0));
5927 cl
.backend_decl
= tmp
;
5930 /* Set up a charlen structure for it. */
5935 len
= cl
.backend_decl
;
5938 byref
= (comp
&& (comp
->attr
.dimension
5939 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5940 || (!comp
&& gfc_return_by_reference (sym
));
5943 if (se
->direct_byref
)
5945 /* Sometimes, too much indirection can be applied; e.g. for
5946 function_result = array_valued_recursive_function. */
5947 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5948 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5949 && GFC_DESCRIPTOR_TYPE_P
5950 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5951 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5954 /* If the lhs of an assignment x = f(..) is allocatable and
5955 f2003 is allowed, we must do the automatic reallocation.
5956 TODO - deal with intrinsics, without using a temporary. */
5957 if (flag_realloc_lhs
5958 && se
->ss
&& se
->ss
->loop_chain
5959 && se
->ss
->loop_chain
->is_alloc_lhs
5960 && !expr
->value
.function
.isym
5961 && sym
->result
->as
!= NULL
)
5963 /* Evaluate the bounds of the result, if known. */
5964 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5967 /* Perform the automatic reallocation. */
5968 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5970 gfc_add_expr_to_block (&se
->pre
, tmp
);
5972 /* Pass the temporary as the first argument. */
5973 result
= info
->descriptor
;
5976 result
= build_fold_indirect_ref_loc (input_location
,
5978 vec_safe_push (retargs
, se
->expr
);
5980 else if (comp
&& comp
->attr
.dimension
)
5982 gcc_assert (se
->loop
&& info
);
5984 /* Set the type of the array. */
5985 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5986 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5988 /* Evaluate the bounds of the result, if known. */
5989 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5991 /* If the lhs of an assignment x = f(..) is allocatable and
5992 f2003 is allowed, we must not generate the function call
5993 here but should just send back the results of the mapping.
5994 This is signalled by the function ss being flagged. */
5995 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5997 gfc_free_interface_mapping (&mapping
);
5998 return has_alternate_specifier
;
6001 /* Create a temporary to store the result. In case the function
6002 returns a pointer, the temporary will be a shallow copy and
6003 mustn't be deallocated. */
6004 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6005 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6006 tmp
, NULL_TREE
, false,
6007 !comp
->attr
.pointer
, callee_alloc
,
6008 &se
->ss
->info
->expr
->where
);
6010 /* Pass the temporary as the first argument. */
6011 result
= info
->descriptor
;
6012 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6013 vec_safe_push (retargs
, tmp
);
6015 else if (!comp
&& sym
->result
->attr
.dimension
)
6017 gcc_assert (se
->loop
&& info
);
6019 /* Set the type of the array. */
6020 tmp
= gfc_typenode_for_spec (&ts
);
6021 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6023 /* Evaluate the bounds of the result, if known. */
6024 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6026 /* If the lhs of an assignment x = f(..) is allocatable and
6027 f2003 is allowed, we must not generate the function call
6028 here but should just send back the results of the mapping.
6029 This is signalled by the function ss being flagged. */
6030 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6032 gfc_free_interface_mapping (&mapping
);
6033 return has_alternate_specifier
;
6036 /* Create a temporary to store the result. In case the function
6037 returns a pointer, the temporary will be a shallow copy and
6038 mustn't be deallocated. */
6039 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6040 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6041 tmp
, NULL_TREE
, false,
6042 !sym
->attr
.pointer
, callee_alloc
,
6043 &se
->ss
->info
->expr
->where
);
6045 /* Pass the temporary as the first argument. */
6046 result
= info
->descriptor
;
6047 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6048 vec_safe_push (retargs
, tmp
);
6050 else if (ts
.type
== BT_CHARACTER
)
6052 /* Pass the string length. */
6053 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6054 type
= build_pointer_type (type
);
6056 /* Emit a DECL_EXPR for the VLA type. */
6057 tmp
= TREE_TYPE (type
);
6059 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6061 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6062 DECL_ARTIFICIAL (tmp
) = 1;
6063 DECL_IGNORED_P (tmp
) = 1;
6064 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6065 TREE_TYPE (tmp
), tmp
);
6066 gfc_add_expr_to_block (&se
->pre
, tmp
);
6069 /* Return an address to a char[0:len-1]* temporary for
6070 character pointers. */
6071 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6072 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6074 var
= gfc_create_var (type
, "pstr");
6076 if ((!comp
&& sym
->attr
.allocatable
)
6077 || (comp
&& comp
->attr
.allocatable
))
6079 gfc_add_modify (&se
->pre
, var
,
6080 fold_convert (TREE_TYPE (var
),
6081 null_pointer_node
));
6082 tmp
= gfc_call_free (var
);
6083 gfc_add_expr_to_block (&se
->post
, tmp
);
6086 /* Provide an address expression for the function arguments. */
6087 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6090 var
= gfc_conv_string_tmp (se
, type
, len
);
6092 vec_safe_push (retargs
, var
);
6096 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6098 type
= gfc_get_complex_type (ts
.kind
);
6099 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6100 vec_safe_push (retargs
, var
);
6103 /* Add the string length to the argument list. */
6104 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6108 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6109 TREE_STATIC (tmp
) = 1;
6110 gfc_add_modify (&se
->pre
, tmp
,
6111 build_int_cst (TREE_TYPE (tmp
), 0));
6112 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6113 vec_safe_push (retargs
, tmp
);
6115 else if (ts
.type
== BT_CHARACTER
)
6116 vec_safe_push (retargs
, len
);
6118 gfc_free_interface_mapping (&mapping
);
6120 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6121 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6122 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6123 vec_safe_reserve (retargs
, arglen
);
6125 /* Add the return arguments. */
6126 vec_safe_splice (retargs
, arglist
);
6128 /* Add the hidden present status for optional+value to the arguments. */
6129 vec_safe_splice (retargs
, optionalargs
);
6131 /* Add the hidden string length parameters to the arguments. */
6132 vec_safe_splice (retargs
, stringargs
);
6134 /* We may want to append extra arguments here. This is used e.g. for
6135 calls to libgfortran_matmul_??, which need extra information. */
6136 vec_safe_splice (retargs
, append_args
);
6140 /* Generate the actual call. */
6141 if (base_object
== NULL_TREE
)
6142 conv_function_val (se
, sym
, expr
);
6144 conv_base_obj_fcn_val (se
, base_object
, expr
);
6146 /* If there are alternate return labels, function type should be
6147 integer. Can't modify the type in place though, since it can be shared
6148 with other functions. For dummy arguments, the typing is done to
6149 this result, even if it has to be repeated for each call. */
6150 if (has_alternate_specifier
6151 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6153 if (!sym
->attr
.dummy
)
6155 TREE_TYPE (sym
->backend_decl
)
6156 = build_function_type (integer_type_node
,
6157 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6158 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6161 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6164 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6165 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6167 /* Allocatable scalar function results must be freed and nullified
6168 after use. This necessitates the creation of a temporary to
6169 hold the result to prevent duplicate calls. */
6170 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6171 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6172 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6174 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6175 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6177 tmp
= gfc_call_free (tmp
);
6178 gfc_add_expr_to_block (&post
, tmp
);
6179 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6182 /* If we have a pointer function, but we don't want a pointer, e.g.
6185 where f is pointer valued, we have to dereference the result. */
6186 if (!se
->want_pointer
&& !byref
6187 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6188 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6189 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6191 /* f2c calling conventions require a scalar default real function to
6192 return a double precision result. Convert this back to default
6193 real. We only care about the cases that can happen in Fortran 77.
6195 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6196 && sym
->ts
.kind
== gfc_default_real_kind
6197 && !sym
->attr
.always_explicit
)
6198 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6200 /* A pure function may still have side-effects - it may modify its
6202 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6204 if (!sym
->attr
.pure
)
6205 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6210 /* Add the function call to the pre chain. There is no expression. */
6211 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6212 se
->expr
= NULL_TREE
;
6214 if (!se
->direct_byref
)
6216 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6218 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6220 /* Check the data pointer hasn't been modified. This would
6221 happen in a function returning a pointer. */
6222 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6223 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6226 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6229 se
->expr
= info
->descriptor
;
6230 /* Bundle in the string length. */
6231 se
->string_length
= len
;
6233 else if (ts
.type
== BT_CHARACTER
)
6235 /* Dereference for character pointer results. */
6236 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6237 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6238 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6242 se
->string_length
= len
;
6246 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6247 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6252 /* Associate the rhs class object's meta-data with the result, when the
6253 result is a temporary. */
6254 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6255 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6256 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6259 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6261 gfc_init_se (&parmse
, NULL
);
6262 parmse
.data_not_needed
= 1;
6263 gfc_conv_expr (&parmse
, class_expr
);
6264 if (!DECL_LANG_SPECIFIC (result
))
6265 gfc_allocate_lang_decl (result
);
6266 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6267 gfc_free_expr (class_expr
);
6268 gcc_assert (parmse
.pre
.head
== NULL_TREE
6269 && parmse
.post
.head
== NULL_TREE
);
6272 /* Follow the function call with the argument post block. */
6275 gfc_add_block_to_block (&se
->pre
, &post
);
6277 /* Transformational functions of derived types with allocatable
6278 components must have the result allocatable components copied when the
6279 argument is actually given. */
6280 arg
= expr
->value
.function
.actual
;
6281 if (result
&& arg
&& expr
->rank
6282 && expr
->value
.function
.isym
6283 && expr
->value
.function
.isym
->transformational
6285 && arg
->expr
->ts
.type
== BT_DERIVED
6286 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6289 /* Copy the allocatable components. We have to use a
6290 temporary here to prevent source allocatable components
6291 from being corrupted. */
6292 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6293 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6294 result
, tmp2
, expr
->rank
, 0);
6295 gfc_add_expr_to_block (&se
->pre
, tmp
);
6296 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6298 gfc_add_expr_to_block (&se
->pre
, tmp
);
6300 /* Finally free the temporary's data field. */
6301 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6302 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6303 NULL_TREE
, NULL_TREE
, true,
6304 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6305 gfc_add_expr_to_block (&se
->pre
, tmp
);
6310 /* For a function with a class array result, save the result as
6311 a temporary, set the info fields needed by the scalarizer and
6312 call the finalization function of the temporary. Note that the
6313 nullification of allocatable components needed by the result
6314 is done in gfc_trans_assignment_1. */
6315 if (expr
&& ((gfc_is_class_array_function (expr
)
6316 && se
->ss
&& se
->ss
->loop
)
6317 || gfc_is_alloc_class_scalar_function (expr
))
6318 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6319 && expr
->must_finalize
)
6324 if (se
->ss
&& se
->ss
->loop
)
6326 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
6327 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6328 tmp
= gfc_class_data_get (se
->expr
);
6329 info
->descriptor
= tmp
;
6330 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6331 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6332 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6334 tree dim
= gfc_rank_cst
[n
];
6335 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6336 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6341 /* TODO Eliminate the doubling of temporaries. This
6342 one is necessary to ensure no memory leakage. */
6343 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6344 tmp
= gfc_class_data_get (se
->expr
);
6345 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6346 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6349 if ((gfc_is_class_array_function (expr
)
6350 || gfc_is_alloc_class_scalar_function (expr
))
6351 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
6352 goto no_finalization
;
6354 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6355 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6358 fold_convert (TREE_TYPE (final_fndecl
),
6359 null_pointer_node
));
6360 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6362 tmp
= build_call_expr_loc (input_location
,
6364 gfc_build_addr_expr (NULL
, tmp
),
6365 gfc_class_vtab_size_get (se
->expr
),
6366 boolean_false_node
);
6367 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6368 void_type_node
, is_final
, tmp
,
6369 build_empty_stmt (input_location
));
6371 if (se
->ss
&& se
->ss
->loop
)
6373 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6374 tmp
= gfc_call_free (info
->data
);
6375 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6379 gfc_add_expr_to_block (&se
->post
, tmp
);
6380 tmp
= gfc_class_data_get (se
->expr
);
6381 tmp
= gfc_call_free (tmp
);
6382 gfc_add_expr_to_block (&se
->post
, tmp
);
6386 expr
->must_finalize
= 0;
6389 gfc_add_block_to_block (&se
->post
, &post
);
6392 return has_alternate_specifier
;
6396 /* Fill a character string with spaces. */
6399 fill_with_spaces (tree start
, tree type
, tree size
)
6401 stmtblock_t block
, loop
;
6402 tree i
, el
, exit_label
, cond
, tmp
;
6404 /* For a simple char type, we can call memset(). */
6405 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6406 return build_call_expr_loc (input_location
,
6407 builtin_decl_explicit (BUILT_IN_MEMSET
),
6409 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6410 lang_hooks
.to_target_charset (' ')),
6413 /* Otherwise, we use a loop:
6414 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6418 /* Initialize variables. */
6419 gfc_init_block (&block
);
6420 i
= gfc_create_var (sizetype
, "i");
6421 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6422 el
= gfc_create_var (build_pointer_type (type
), "el");
6423 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6424 exit_label
= gfc_build_label_decl (NULL_TREE
);
6425 TREE_USED (exit_label
) = 1;
6429 gfc_init_block (&loop
);
6431 /* Exit condition. */
6432 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6433 build_zero_cst (sizetype
));
6434 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6435 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6436 build_empty_stmt (input_location
));
6437 gfc_add_expr_to_block (&loop
, tmp
);
6440 gfc_add_modify (&loop
,
6441 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6442 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6444 /* Increment loop variables. */
6445 gfc_add_modify (&loop
, i
,
6446 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6447 TYPE_SIZE_UNIT (type
)));
6448 gfc_add_modify (&loop
, el
,
6449 fold_build_pointer_plus_loc (input_location
,
6450 el
, TYPE_SIZE_UNIT (type
)));
6452 /* Making the loop... actually loop! */
6453 tmp
= gfc_finish_block (&loop
);
6454 tmp
= build1_v (LOOP_EXPR
, tmp
);
6455 gfc_add_expr_to_block (&block
, tmp
);
6457 /* The exit label. */
6458 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6459 gfc_add_expr_to_block (&block
, tmp
);
6462 return gfc_finish_block (&block
);
6466 /* Generate code to copy a string. */
6469 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6470 int dkind
, tree slength
, tree src
, int skind
)
6472 tree tmp
, dlen
, slen
;
6481 stmtblock_t tempblock
;
6483 gcc_assert (dkind
== skind
);
6485 if (slength
!= NULL_TREE
)
6487 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6488 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6492 slen
= build_int_cst (size_type_node
, 1);
6496 if (dlength
!= NULL_TREE
)
6498 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6499 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6503 dlen
= build_int_cst (size_type_node
, 1);
6507 /* Assign directly if the types are compatible. */
6508 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6509 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6511 gfc_add_modify (block
, dsc
, ssc
);
6515 /* The string copy algorithm below generates code like
6518 memmove (dest, src, min(dlen, slen));
6520 memset(&dest[slen], ' ', dlen - slen);
6524 /* Do nothing if the destination length is zero. */
6525 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6526 build_int_cst (size_type_node
, 0));
6528 /* For non-default character kinds, we have to multiply the string
6529 length by the base type size. */
6530 chartype
= gfc_get_char_type (dkind
);
6531 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6532 fold_convert (size_type_node
, slen
),
6533 fold_convert (size_type_node
,
6534 TYPE_SIZE_UNIT (chartype
)));
6535 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6536 fold_convert (size_type_node
, dlen
),
6537 fold_convert (size_type_node
,
6538 TYPE_SIZE_UNIT (chartype
)));
6540 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6541 dest
= fold_convert (pvoid_type_node
, dest
);
6543 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6545 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6546 src
= fold_convert (pvoid_type_node
, src
);
6548 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6550 /* First do the memmove. */
6551 tmp2
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (dlen
), dlen
,
6553 tmp2
= build_call_expr_loc (input_location
,
6554 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6555 3, dest
, src
, tmp2
);
6556 stmtblock_t tmpblock2
;
6557 gfc_init_block (&tmpblock2
);
6558 gfc_add_expr_to_block (&tmpblock2
, tmp2
);
6560 /* If the destination is longer, fill the end with spaces. */
6561 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6564 /* Wstringop-overflow appears at -O3 even though this warning is not
6565 explicitly available in fortran nor can it be switched off. If the
6566 source length is a constant, its negative appears as a very large
6567 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6568 the result of the MINUS_EXPR suppresses this spurious warning. */
6569 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6570 TREE_TYPE(dlen
), dlen
, slen
);
6571 if (slength
&& TREE_CONSTANT (slength
))
6572 tmp
= gfc_evaluate_now (tmp
, block
);
6574 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6575 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6577 gfc_init_block (&tempblock
);
6578 gfc_add_expr_to_block (&tempblock
, tmp4
);
6579 tmp3
= gfc_finish_block (&tempblock
);
6581 /* The whole copy_string function is there. */
6582 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6583 tmp3
, build_empty_stmt (input_location
));
6584 gfc_add_expr_to_block (&tmpblock2
, tmp
);
6585 tmp
= gfc_finish_block (&tmpblock2
);
6586 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6587 build_empty_stmt (input_location
));
6588 gfc_add_expr_to_block (block
, tmp
);
6592 /* Translate a statement function.
6593 The value of a statement function reference is obtained by evaluating the
6594 expression using the values of the actual arguments for the values of the
6595 corresponding dummy arguments. */
6598 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6602 gfc_formal_arglist
*fargs
;
6603 gfc_actual_arglist
*args
;
6606 gfc_saved_var
*saved_vars
;
6612 sym
= expr
->symtree
->n
.sym
;
6613 args
= expr
->value
.function
.actual
;
6614 gfc_init_se (&lse
, NULL
);
6615 gfc_init_se (&rse
, NULL
);
6618 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6620 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6621 temp_vars
= XCNEWVEC (tree
, n
);
6623 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6624 fargs
= fargs
->next
, n
++)
6626 /* Each dummy shall be specified, explicitly or implicitly, to be
6628 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6631 if (fsym
->ts
.type
== BT_CHARACTER
)
6633 /* Copy string arguments. */
6636 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6637 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6639 /* Create a temporary to hold the value. */
6640 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6641 fsym
->ts
.u
.cl
->backend_decl
6642 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6644 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6645 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6647 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6649 gfc_conv_expr (&rse
, args
->expr
);
6650 gfc_conv_string_parameter (&rse
);
6651 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6652 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6654 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6655 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6656 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6657 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6661 /* For everything else, just evaluate the expression. */
6663 /* Create a temporary to hold the value. */
6664 type
= gfc_typenode_for_spec (&fsym
->ts
);
6665 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6667 gfc_conv_expr (&lse
, args
->expr
);
6669 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6670 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6671 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6677 /* Use the temporary variables in place of the real ones. */
6678 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6679 fargs
= fargs
->next
, n
++)
6680 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6682 gfc_conv_expr (se
, sym
->value
);
6684 if (sym
->ts
.type
== BT_CHARACTER
)
6686 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6688 /* Force the expression to the correct length. */
6689 if (!INTEGER_CST_P (se
->string_length
)
6690 || tree_int_cst_lt (se
->string_length
,
6691 sym
->ts
.u
.cl
->backend_decl
))
6693 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6694 tmp
= gfc_create_var (type
, sym
->name
);
6695 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6696 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6697 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6701 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6704 /* Restore the original variables. */
6705 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6706 fargs
= fargs
->next
, n
++)
6707 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6713 /* Translate a function expression. */
6716 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6720 if (expr
->value
.function
.isym
)
6722 gfc_conv_intrinsic_function (se
, expr
);
6726 /* expr.value.function.esym is the resolved (specific) function symbol for
6727 most functions. However this isn't set for dummy procedures. */
6728 sym
= expr
->value
.function
.esym
;
6730 sym
= expr
->symtree
->n
.sym
;
6732 /* The IEEE_ARITHMETIC functions are caught here. */
6733 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6734 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6737 /* We distinguish statement functions from general functions to improve
6738 runtime performance. */
6739 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6741 gfc_conv_statement_function (se
, expr
);
6745 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6750 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6753 is_zero_initializer_p (gfc_expr
* expr
)
6755 if (expr
->expr_type
!= EXPR_CONSTANT
)
6758 /* We ignore constants with prescribed memory representations for now. */
6759 if (expr
->representation
.string
)
6762 switch (expr
->ts
.type
)
6765 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6768 return mpfr_zero_p (expr
->value
.real
)
6769 && MPFR_SIGN (expr
->value
.real
) >= 0;
6772 return expr
->value
.logical
== 0;
6775 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6776 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6777 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6778 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6788 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6793 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6794 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6796 gfc_conv_tmp_array_ref (se
);
6800 /* Build a static initializer. EXPR is the expression for the initial value.
6801 The other parameters describe the variable of the component being
6802 initialized. EXPR may be null. */
6805 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6806 bool array
, bool pointer
, bool procptr
)
6810 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6811 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6812 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6813 return build_constructor (type
, NULL
);
6815 if (!(expr
|| pointer
|| procptr
))
6818 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6819 (these are the only two iso_c_binding derived types that can be
6820 used as initialization expressions). If so, we need to modify
6821 the 'expr' to be that for a (void *). */
6822 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6823 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6825 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6827 /* The derived symbol has already been converted to a (void *). Use
6829 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6830 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6832 gfc_init_se (&se
, NULL
);
6833 gfc_conv_constant (&se
, expr
);
6834 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6838 if (array
&& !procptr
)
6841 /* Arrays need special handling. */
6843 ctor
= gfc_build_null_descriptor (type
);
6844 /* Special case assigning an array to zero. */
6845 else if (is_zero_initializer_p (expr
))
6846 ctor
= build_constructor (type
, NULL
);
6848 ctor
= gfc_conv_array_initializer (type
, expr
);
6849 TREE_STATIC (ctor
) = 1;
6852 else if (pointer
|| procptr
)
6854 if (ts
->type
== BT_CLASS
&& !procptr
)
6856 gfc_init_se (&se
, NULL
);
6857 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6858 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6859 TREE_STATIC (se
.expr
) = 1;
6862 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6863 return fold_convert (type
, null_pointer_node
);
6866 gfc_init_se (&se
, NULL
);
6867 se
.want_pointer
= 1;
6868 gfc_conv_expr (&se
, expr
);
6869 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6879 gfc_init_se (&se
, NULL
);
6880 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6881 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6883 gfc_conv_structure (&se
, expr
, 1);
6884 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6885 TREE_STATIC (se
.expr
) = 1;
6890 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6891 TREE_STATIC (ctor
) = 1;
6896 gfc_init_se (&se
, NULL
);
6897 gfc_conv_constant (&se
, expr
);
6898 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6905 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6911 gfc_array_info
*lss_array
;
6918 gfc_start_block (&block
);
6920 /* Initialize the scalarizer. */
6921 gfc_init_loopinfo (&loop
);
6923 gfc_init_se (&lse
, NULL
);
6924 gfc_init_se (&rse
, NULL
);
6927 rss
= gfc_walk_expr (expr
);
6928 if (rss
== gfc_ss_terminator
)
6929 /* The rhs is scalar. Add a ss for the expression. */
6930 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6932 /* Create a SS for the destination. */
6933 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6935 lss_array
= &lss
->info
->data
.array
;
6936 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6937 lss_array
->descriptor
= dest
;
6938 lss_array
->data
= gfc_conv_array_data (dest
);
6939 lss_array
->offset
= gfc_conv_array_offset (dest
);
6940 for (n
= 0; n
< cm
->as
->rank
; n
++)
6942 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6943 lss_array
->stride
[n
] = gfc_index_one_node
;
6945 mpz_init (lss_array
->shape
[n
]);
6946 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6947 cm
->as
->lower
[n
]->value
.integer
);
6948 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6951 /* Associate the SS with the loop. */
6952 gfc_add_ss_to_loop (&loop
, lss
);
6953 gfc_add_ss_to_loop (&loop
, rss
);
6955 /* Calculate the bounds of the scalarization. */
6956 gfc_conv_ss_startstride (&loop
);
6958 /* Setup the scalarizing loops. */
6959 gfc_conv_loop_setup (&loop
, &expr
->where
);
6961 /* Setup the gfc_se structures. */
6962 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6963 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6966 gfc_mark_ss_chain_used (rss
, 1);
6968 gfc_mark_ss_chain_used (lss
, 1);
6970 /* Start the scalarized loop body. */
6971 gfc_start_scalarized_body (&loop
, &body
);
6973 gfc_conv_tmp_array_ref (&lse
);
6974 if (cm
->ts
.type
== BT_CHARACTER
)
6975 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6977 gfc_conv_expr (&rse
, expr
);
6979 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6980 gfc_add_expr_to_block (&body
, tmp
);
6982 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6984 /* Generate the copying loops. */
6985 gfc_trans_scalarizing_loops (&loop
, &body
);
6987 /* Wrap the whole thing up. */
6988 gfc_add_block_to_block (&block
, &loop
.pre
);
6989 gfc_add_block_to_block (&block
, &loop
.post
);
6991 gcc_assert (lss_array
->shape
!= NULL
);
6992 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6993 gfc_cleanup_loop (&loop
);
6995 return gfc_finish_block (&block
);
7000 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7010 gfc_expr
*arg
= NULL
;
7012 gfc_start_block (&block
);
7013 gfc_init_se (&se
, NULL
);
7015 /* Get the descriptor for the expressions. */
7016 se
.want_pointer
= 0;
7017 gfc_conv_expr_descriptor (&se
, expr
);
7018 gfc_add_block_to_block (&block
, &se
.pre
);
7019 gfc_add_modify (&block
, dest
, se
.expr
);
7021 /* Deal with arrays of derived types with allocatable components. */
7022 if (gfc_bt_struct (cm
->ts
.type
)
7023 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7024 // TODO: Fix caf_mode
7025 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7028 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7029 && CLASS_DATA(cm
)->attr
.allocatable
)
7031 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7032 // TODO: Fix caf_mode
7033 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7038 tmp
= TREE_TYPE (dest
);
7039 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7040 tmp
, expr
->rank
, NULL_TREE
);
7044 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7045 TREE_TYPE(cm
->backend_decl
),
7046 cm
->as
->rank
, NULL_TREE
);
7048 gfc_add_expr_to_block (&block
, tmp
);
7049 gfc_add_block_to_block (&block
, &se
.post
);
7051 if (expr
->expr_type
!= EXPR_VARIABLE
)
7052 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7055 /* We need to know if the argument of a conversion function is a
7056 variable, so that the correct lower bound can be used. */
7057 if (expr
->expr_type
== EXPR_FUNCTION
7058 && expr
->value
.function
.isym
7059 && expr
->value
.function
.isym
->conversion
7060 && expr
->value
.function
.actual
->expr
7061 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7062 arg
= expr
->value
.function
.actual
->expr
;
7064 /* Obtain the array spec of full array references. */
7066 as
= gfc_get_full_arrayspec_from_expr (arg
);
7068 as
= gfc_get_full_arrayspec_from_expr (expr
);
7070 /* Shift the lbound and ubound of temporaries to being unity,
7071 rather than zero, based. Always calculate the offset. */
7072 offset
= gfc_conv_descriptor_offset_get (dest
);
7073 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7074 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7076 for (n
= 0; n
< expr
->rank
; n
++)
7081 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7082 TODO It looks as if gfc_conv_expr_descriptor should return
7083 the correct bounds and that the following should not be
7084 necessary. This would simplify gfc_conv_intrinsic_bound
7086 if (as
&& as
->lower
[n
])
7089 gfc_init_se (&lbse
, NULL
);
7090 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7091 gfc_add_block_to_block (&block
, &lbse
.pre
);
7092 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7096 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7097 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7101 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7104 lbound
= gfc_index_one_node
;
7106 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7108 /* Shift the bounds and set the offset accordingly. */
7109 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7110 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7111 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7112 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7114 gfc_conv_descriptor_ubound_set (&block
, dest
,
7115 gfc_rank_cst
[n
], tmp
);
7116 gfc_conv_descriptor_lbound_set (&block
, dest
,
7117 gfc_rank_cst
[n
], lbound
);
7119 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7120 gfc_conv_descriptor_lbound_get (dest
,
7122 gfc_conv_descriptor_stride_get (dest
,
7124 gfc_add_modify (&block
, tmp2
, tmp
);
7125 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7127 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7132 /* If a conversion expression has a null data pointer
7133 argument, nullify the allocatable component. */
7137 if (arg
->symtree
->n
.sym
->attr
.allocatable
7138 || arg
->symtree
->n
.sym
->attr
.pointer
)
7140 non_null_expr
= gfc_finish_block (&block
);
7141 gfc_start_block (&block
);
7142 gfc_conv_descriptor_data_set (&block
, dest
,
7144 null_expr
= gfc_finish_block (&block
);
7145 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7146 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7147 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7148 return build3_v (COND_EXPR
, tmp
,
7149 null_expr
, non_null_expr
);
7153 return gfc_finish_block (&block
);
7157 /* Allocate or reallocate scalar component, as necessary. */
7160 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7170 tree lhs_cl_size
= NULL_TREE
;
7175 if (!expr2
|| expr2
->rank
)
7178 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7180 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7182 char name
[GFC_MAX_SYMBOL_LEN
+9];
7183 gfc_component
*strlen
;
7184 /* Use the rhs string length and the lhs element size. */
7185 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7186 if (!expr2
->ts
.u
.cl
->backend_decl
)
7188 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7189 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7192 size
= expr2
->ts
.u
.cl
->backend_decl
;
7194 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7196 sprintf (name
, "_%s_length", cm
->name
);
7197 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7198 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7199 gfc_charlen_type_node
,
7200 TREE_OPERAND (comp
, 0),
7201 strlen
->backend_decl
, NULL_TREE
);
7203 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7204 tmp
= TYPE_SIZE_UNIT (tmp
);
7205 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7206 TREE_TYPE (tmp
), tmp
,
7207 fold_convert (TREE_TYPE (tmp
), size
));
7209 else if (cm
->ts
.type
== BT_CLASS
)
7211 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7212 if (expr2
->ts
.type
== BT_DERIVED
)
7214 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7215 size
= TYPE_SIZE_UNIT (tmp
);
7221 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7222 gfc_add_vptr_component (e2vtab
);
7223 gfc_add_size_component (e2vtab
);
7224 gfc_init_se (&se
, NULL
);
7225 gfc_conv_expr (&se
, e2vtab
);
7226 gfc_add_block_to_block (block
, &se
.pre
);
7227 size
= fold_convert (size_type_node
, se
.expr
);
7228 gfc_free_expr (e2vtab
);
7230 size_in_bytes
= size
;
7234 /* Otherwise use the length in bytes of the rhs. */
7235 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7236 size_in_bytes
= size
;
7239 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7240 size_in_bytes
, size_one_node
);
7242 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7244 tmp
= build_call_expr_loc (input_location
,
7245 builtin_decl_explicit (BUILT_IN_CALLOC
),
7246 2, build_one_cst (size_type_node
),
7248 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7249 gfc_add_modify (block
, comp
, tmp
);
7253 tmp
= build_call_expr_loc (input_location
,
7254 builtin_decl_explicit (BUILT_IN_MALLOC
),
7256 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7257 ptr
= gfc_class_data_get (comp
);
7260 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7261 gfc_add_modify (block
, ptr
, tmp
);
7264 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7265 /* Update the lhs character length. */
7266 gfc_add_modify (block
, lhs_cl_size
, size
);
7270 /* Assign a single component of a derived type constructor. */
7273 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7274 gfc_symbol
*sym
, bool init
)
7282 gfc_start_block (&block
);
7284 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7286 /* Only care about pointers here, not about allocatables. */
7287 gfc_init_se (&se
, NULL
);
7288 /* Pointer component. */
7289 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7290 && !cm
->attr
.proc_pointer
)
7292 /* Array pointer. */
7293 if (expr
->expr_type
== EXPR_NULL
)
7294 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7297 se
.direct_byref
= 1;
7299 gfc_conv_expr_descriptor (&se
, expr
);
7300 gfc_add_block_to_block (&block
, &se
.pre
);
7301 gfc_add_block_to_block (&block
, &se
.post
);
7306 /* Scalar pointers. */
7307 se
.want_pointer
= 1;
7308 gfc_conv_expr (&se
, expr
);
7309 gfc_add_block_to_block (&block
, &se
.pre
);
7311 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7312 && expr
->symtree
->n
.sym
->attr
.dummy
)
7313 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7315 gfc_add_modify (&block
, dest
,
7316 fold_convert (TREE_TYPE (dest
), se
.expr
));
7317 gfc_add_block_to_block (&block
, &se
.post
);
7320 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7322 /* NULL initialization for CLASS components. */
7323 tmp
= gfc_trans_structure_assign (dest
,
7324 gfc_class_initializer (&cm
->ts
, expr
),
7326 gfc_add_expr_to_block (&block
, tmp
);
7328 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7329 && !cm
->attr
.proc_pointer
)
7331 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7332 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7333 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7335 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7336 gfc_add_expr_to_block (&block
, tmp
);
7340 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7341 gfc_add_expr_to_block (&block
, tmp
);
7344 else if (cm
->ts
.type
== BT_CLASS
7345 && CLASS_DATA (cm
)->attr
.dimension
7346 && CLASS_DATA (cm
)->attr
.allocatable
7347 && expr
->ts
.type
== BT_DERIVED
)
7349 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7350 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7351 tmp
= gfc_class_vptr_get (dest
);
7352 gfc_add_modify (&block
, tmp
,
7353 fold_convert (TREE_TYPE (tmp
), vtab
));
7354 tmp
= gfc_class_data_get (dest
);
7355 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7356 gfc_add_expr_to_block (&block
, tmp
);
7358 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7360 /* NULL initialization for allocatable components. */
7361 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7362 null_pointer_node
));
7364 else if (init
&& (cm
->attr
.allocatable
7365 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7366 && expr
->ts
.type
!= BT_CLASS
)))
7368 /* Take care about non-array allocatable components here. The alloc_*
7369 routine below is motivated by the alloc_scalar_allocatable_for_
7370 assignment() routine, but with the realloc portions removed and
7372 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7377 /* The remainder of these instructions follow the if (cm->attr.pointer)
7378 if (!cm->attr.dimension) part above. */
7379 gfc_init_se (&se
, NULL
);
7380 gfc_conv_expr (&se
, expr
);
7381 gfc_add_block_to_block (&block
, &se
.pre
);
7383 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7384 && expr
->symtree
->n
.sym
->attr
.dummy
)
7385 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7387 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7389 tmp
= gfc_class_data_get (dest
);
7390 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7391 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7392 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7393 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7394 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7397 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7399 /* For deferred strings insert a memcpy. */
7400 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7403 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7404 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7406 : expr
->ts
.u
.cl
->backend_decl
);
7407 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7408 gfc_add_expr_to_block (&block
, tmp
);
7411 gfc_add_modify (&block
, tmp
,
7412 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7413 gfc_add_block_to_block (&block
, &se
.post
);
7415 else if (expr
->ts
.type
== BT_UNION
)
7418 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7419 /* We mark that the entire union should be initialized with a contrived
7420 EXPR_NULL expression at the beginning. */
7421 if (c
!= NULL
&& c
->n
.component
== NULL
7422 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7424 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7425 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7426 gfc_add_expr_to_block (&block
, tmp
);
7427 c
= gfc_constructor_next (c
);
7429 /* The following constructor expression, if any, represents a specific
7430 map intializer, as given by the user. */
7431 if (c
!= NULL
&& c
->expr
!= NULL
)
7433 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7434 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7435 gfc_add_expr_to_block (&block
, tmp
);
7438 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7440 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7442 tree dealloc
= NULL_TREE
;
7443 gfc_init_se (&se
, NULL
);
7444 gfc_conv_expr (&se
, expr
);
7445 gfc_add_block_to_block (&block
, &se
.pre
);
7446 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7447 expression in a temporary variable and deallocate the allocatable
7448 components. Then we can the copy the expression to the result. */
7449 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7450 && expr
->expr_type
!= EXPR_VARIABLE
)
7452 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7453 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7456 gfc_add_modify (&block
, dest
,
7457 fold_convert (TREE_TYPE (dest
), se
.expr
));
7458 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7459 && expr
->expr_type
!= EXPR_NULL
)
7461 // TODO: Fix caf_mode
7462 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7463 dest
, expr
->rank
, 0);
7464 gfc_add_expr_to_block (&block
, tmp
);
7465 if (dealloc
!= NULL_TREE
)
7466 gfc_add_expr_to_block (&block
, dealloc
);
7468 gfc_add_block_to_block (&block
, &se
.post
);
7472 /* Nested constructors. */
7473 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7474 gfc_add_expr_to_block (&block
, tmp
);
7477 else if (gfc_deferred_strlen (cm
, &tmp
))
7481 gcc_assert (strlen
);
7482 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7484 TREE_OPERAND (dest
, 0),
7487 if (expr
->expr_type
== EXPR_NULL
)
7489 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7490 gfc_add_modify (&block
, dest
, tmp
);
7491 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7492 gfc_add_modify (&block
, strlen
, tmp
);
7497 gfc_init_se (&se
, NULL
);
7498 gfc_conv_expr (&se
, expr
);
7499 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7500 tmp
= build_call_expr_loc (input_location
,
7501 builtin_decl_explicit (BUILT_IN_MALLOC
),
7503 gfc_add_modify (&block
, dest
,
7504 fold_convert (TREE_TYPE (dest
), tmp
));
7505 gfc_add_modify (&block
, strlen
, se
.string_length
);
7506 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7507 gfc_add_expr_to_block (&block
, tmp
);
7510 else if (!cm
->attr
.artificial
)
7512 /* Scalar component (excluding deferred parameters). */
7513 gfc_init_se (&se
, NULL
);
7514 gfc_init_se (&lse
, NULL
);
7516 gfc_conv_expr (&se
, expr
);
7517 if (cm
->ts
.type
== BT_CHARACTER
)
7518 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7520 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7521 gfc_add_expr_to_block (&block
, tmp
);
7523 return gfc_finish_block (&block
);
7526 /* Assign a derived type constructor to a variable. */
7529 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7538 gfc_start_block (&block
);
7539 cm
= expr
->ts
.u
.derived
->components
;
7541 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7542 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7543 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7547 gfc_init_se (&se
, NULL
);
7548 gfc_init_se (&lse
, NULL
);
7549 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7551 gfc_add_modify (&block
, lse
.expr
,
7552 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7554 return gfc_finish_block (&block
);
7558 gfc_init_se (&se
, NULL
);
7560 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7561 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7563 /* Skip absent members in default initializers. */
7564 if (!c
->expr
&& !cm
->attr
.allocatable
)
7567 /* Register the component with the caf-lib before it is initialized.
7568 Register only allocatable components, that are not coarray'ed
7569 components (%comp[*]). Only register when the constructor is not the
7571 if (coarray
&& !cm
->attr
.codimension
7572 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7573 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7575 tree token
, desc
, size
;
7576 bool is_array
= cm
->ts
.type
== BT_CLASS
7577 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7579 field
= cm
->backend_decl
;
7580 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7581 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7582 if (cm
->ts
.type
== BT_CLASS
)
7583 field
= gfc_class_data_get (field
);
7585 token
= is_array
? gfc_conv_descriptor_token (field
)
7586 : fold_build3_loc (input_location
, COMPONENT_REF
,
7587 TREE_TYPE (cm
->caf_token
), dest
,
7588 cm
->caf_token
, NULL_TREE
);
7592 /* The _caf_register routine looks at the rank of the array
7593 descriptor to decide whether the data registered is an array
7595 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7597 /* When the rank is not known just set a positive rank, which
7598 suffices to recognize the data as array. */
7601 size
= integer_zero_node
;
7603 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
7604 build_int_cst (gfc_array_index_type
, rank
));
7608 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
7609 cm
->ts
.type
== BT_CLASS
7610 ? CLASS_DATA (cm
)->attr
7612 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7614 gfc_add_block_to_block (&block
, &se
.pre
);
7615 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7616 7, size
, build_int_cst (
7618 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7619 gfc_build_addr_expr (pvoid_type_node
,
7621 gfc_build_addr_expr (NULL_TREE
, desc
),
7622 null_pointer_node
, null_pointer_node
,
7624 gfc_add_expr_to_block (&block
, tmp
);
7626 field
= cm
->backend_decl
;
7627 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7628 dest
, field
, NULL_TREE
);
7631 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7632 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7637 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7638 expr
->ts
.u
.derived
, init
);
7639 gfc_add_expr_to_block (&block
, tmp
);
7641 return gfc_finish_block (&block
);
7645 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7646 gfc_component
*un
, gfc_expr
*init
)
7648 gfc_constructor
*ctor
;
7650 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7653 ctor
= gfc_constructor_first (init
->value
.constructor
);
7655 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7658 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7660 /* If we have an 'initialize all' constructor, do it first. */
7661 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7663 tree union_type
= TREE_TYPE (un
->backend_decl
);
7664 tree val
= build_constructor (union_type
, NULL
);
7665 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7666 ctor
= gfc_constructor_next (ctor
);
7669 /* Add the map initializer on top. */
7670 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7672 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7673 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7674 TREE_TYPE (un
->backend_decl
),
7675 un
->attr
.dimension
, un
->attr
.pointer
,
7676 un
->attr
.proc_pointer
);
7677 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7681 /* Build an expression for a constructor. If init is nonzero then
7682 this is part of a static variable initializer. */
7685 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7692 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7694 gcc_assert (se
->ss
== NULL
);
7695 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7696 type
= gfc_typenode_for_spec (&expr
->ts
);
7700 /* Create a temporary variable and fill it in. */
7701 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7702 /* The symtree in expr is NULL, if the code to generate is for
7703 initializing the static members only. */
7704 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7706 gfc_add_expr_to_block (&se
->pre
, tmp
);
7710 cm
= expr
->ts
.u
.derived
->components
;
7712 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7713 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7715 /* Skip absent members in default initializers and allocatable
7716 components. Although the latter have a default initializer
7717 of EXPR_NULL,... by default, the static nullify is not needed
7718 since this is done every time we come into scope. */
7719 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7722 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7723 && strcmp (cm
->name
, "_extends") == 0
7724 && cm
->initializer
->symtree
)
7728 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7729 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7730 vtab
= unshare_expr_without_location (vtab
);
7731 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7733 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7735 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7736 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7737 fold_convert (TREE_TYPE (cm
->backend_decl
),
7740 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7741 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7742 fold_convert (TREE_TYPE (cm
->backend_decl
),
7743 integer_zero_node
));
7744 else if (cm
->ts
.type
== BT_UNION
)
7745 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7748 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7749 TREE_TYPE (cm
->backend_decl
),
7750 cm
->attr
.dimension
, cm
->attr
.pointer
,
7751 cm
->attr
.proc_pointer
);
7752 val
= unshare_expr_without_location (val
);
7754 /* Append it to the constructor list. */
7755 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7759 se
->expr
= build_constructor (type
, v
);
7761 TREE_CONSTANT (se
->expr
) = 1;
7765 /* Translate a substring expression. */
7768 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7774 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7776 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7777 expr
->value
.character
.length
,
7778 expr
->value
.character
.string
);
7780 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7781 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7784 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7788 /* Entry point for expression translation. Evaluates a scalar quantity.
7789 EXPR is the expression to be translated, and SE is the state structure if
7790 called from within the scalarized. */
7793 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7798 if (ss
&& ss
->info
->expr
== expr
7799 && (ss
->info
->type
== GFC_SS_SCALAR
7800 || ss
->info
->type
== GFC_SS_REFERENCE
))
7802 gfc_ss_info
*ss_info
;
7805 /* Substitute a scalar expression evaluated outside the scalarization
7807 se
->expr
= ss_info
->data
.scalar
.value
;
7808 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7809 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7811 se
->string_length
= ss_info
->string_length
;
7812 gfc_advance_se_ss_chain (se
);
7816 /* We need to convert the expressions for the iso_c_binding derived types.
7817 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7818 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7819 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7820 updated to be an integer with a kind equal to the size of a (void *). */
7821 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7822 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7824 if (expr
->expr_type
== EXPR_VARIABLE
7825 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7826 || expr
->symtree
->n
.sym
->intmod_sym_id
7827 == ISOCBINDING_NULL_FUNPTR
))
7829 /* Set expr_type to EXPR_NULL, which will result in
7830 null_pointer_node being used below. */
7831 expr
->expr_type
= EXPR_NULL
;
7835 /* Update the type/kind of the expression to be what the new
7836 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7837 expr
->ts
.type
= BT_INTEGER
;
7838 expr
->ts
.f90_type
= BT_VOID
;
7839 expr
->ts
.kind
= gfc_index_integer_kind
;
7843 gfc_fix_class_refs (expr
);
7845 switch (expr
->expr_type
)
7848 gfc_conv_expr_op (se
, expr
);
7852 gfc_conv_function_expr (se
, expr
);
7856 gfc_conv_constant (se
, expr
);
7860 gfc_conv_variable (se
, expr
);
7864 se
->expr
= null_pointer_node
;
7867 case EXPR_SUBSTRING
:
7868 gfc_conv_substring_expr (se
, expr
);
7871 case EXPR_STRUCTURE
:
7872 gfc_conv_structure (se
, expr
, 0);
7876 gfc_conv_array_constructor_expr (se
, expr
);
7885 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7886 of an assignment. */
7888 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7890 gfc_conv_expr (se
, expr
);
7891 /* All numeric lvalues should have empty post chains. If not we need to
7892 figure out a way of rewriting an lvalue so that it has no post chain. */
7893 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7896 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7897 numeric expressions. Used for scalar values where inserting cleanup code
7900 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7904 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7905 gfc_conv_expr (se
, expr
);
7908 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7909 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7911 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7915 /* Helper to translate an expression and convert it to a particular type. */
7917 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7919 gfc_conv_expr_val (se
, expr
);
7920 se
->expr
= convert (type
, se
->expr
);
7924 /* Converts an expression so that it can be passed by reference. Scalar
7928 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7934 if (ss
&& ss
->info
->expr
== expr
7935 && ss
->info
->type
== GFC_SS_REFERENCE
)
7937 /* Returns a reference to the scalar evaluated outside the loop
7939 gfc_conv_expr (se
, expr
);
7941 if (expr
->ts
.type
== BT_CHARACTER
7942 && expr
->expr_type
!= EXPR_FUNCTION
)
7943 gfc_conv_string_parameter (se
);
7945 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7950 if (expr
->ts
.type
== BT_CHARACTER
)
7952 gfc_conv_expr (se
, expr
);
7953 gfc_conv_string_parameter (se
);
7957 if (expr
->expr_type
== EXPR_VARIABLE
)
7959 se
->want_pointer
= 1;
7960 gfc_conv_expr (se
, expr
);
7963 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7964 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7965 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7971 if (expr
->expr_type
== EXPR_FUNCTION
7972 && ((expr
->value
.function
.esym
7973 && expr
->value
.function
.esym
->result
->attr
.pointer
7974 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7975 || (!expr
->value
.function
.esym
&& !expr
->ref
7976 && expr
->symtree
->n
.sym
->attr
.pointer
7977 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7979 se
->want_pointer
= 1;
7980 gfc_conv_expr (se
, expr
);
7981 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7982 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7987 gfc_conv_expr (se
, expr
);
7989 /* Create a temporary var to hold the value. */
7990 if (TREE_CONSTANT (se
->expr
))
7992 tree tmp
= se
->expr
;
7993 STRIP_TYPE_NOPS (tmp
);
7994 var
= build_decl (input_location
,
7995 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7996 DECL_INITIAL (var
) = tmp
;
7997 TREE_STATIC (var
) = 1;
8002 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8003 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8005 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8007 /* Take the address of that value. */
8008 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8012 /* Get the _len component for an unlimited polymorphic expression. */
8015 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8018 gfc_ref
*ref
= expr
->ref
;
8020 gfc_init_se (&se
, NULL
);
8021 while (ref
&& ref
->next
)
8023 gfc_add_len_component (expr
);
8024 gfc_conv_expr (&se
, expr
);
8025 gfc_add_block_to_block (block
, &se
.pre
);
8026 gcc_assert (se
.post
.head
== NULL_TREE
);
8029 gfc_free_ref_list (ref
->next
);
8034 gfc_free_ref_list (expr
->ref
);
8041 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8042 statement-list outside of the scalarizer-loop. When code is generated, that
8043 depends on the scalarized expression, it is added to RSE.PRE.
8044 Returns le's _vptr tree and when set the len expressions in to_lenp and
8045 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8049 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8050 gfc_expr
* re
, gfc_se
*rse
,
8051 tree
* to_lenp
, tree
* from_lenp
)
8054 gfc_expr
* vptr_expr
;
8055 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8056 bool set_vptr
= false, temp_rhs
= false;
8057 stmtblock_t
*pre
= block
;
8059 /* Create a temporary for complicated expressions. */
8060 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8061 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8063 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8065 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8070 /* Get the _vptr for the left-hand side expression. */
8071 gfc_init_se (&se
, NULL
);
8072 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8073 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8075 /* Care about _len for unlimited polymorphic entities. */
8076 if (UNLIMITED_POLY (vptr_expr
)
8077 || (vptr_expr
->ts
.type
== BT_DERIVED
8078 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8079 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8080 gfc_add_vptr_component (vptr_expr
);
8084 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8085 se
.want_pointer
= 1;
8086 gfc_conv_expr (&se
, vptr_expr
);
8087 gfc_free_expr (vptr_expr
);
8088 gfc_add_block_to_block (block
, &se
.pre
);
8089 gcc_assert (se
.post
.head
== NULL_TREE
);
8091 STRIP_NOPS (lhs_vptr
);
8093 /* Set the _vptr only when the left-hand side of the assignment is a
8097 /* Get the vptr from the rhs expression only, when it is variable.
8098 Functions are expected to be assigned to a temporary beforehand. */
8099 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8100 ? gfc_find_and_cut_at_last_class_ref (re
)
8102 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8104 if (to_len
!= NULL_TREE
)
8106 /* Get the _len information from the rhs. */
8107 if (UNLIMITED_POLY (vptr_expr
)
8108 || (vptr_expr
->ts
.type
== BT_DERIVED
8109 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8110 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8112 gfc_add_vptr_component (vptr_expr
);
8116 if (re
->expr_type
== EXPR_VARIABLE
8117 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8118 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8119 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8120 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8121 re
->symtree
->n
.sym
->backend_decl
))))
8124 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8125 re
->symtree
->n
.sym
->backend_decl
));
8127 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8128 re
->symtree
->n
.sym
->backend_decl
));
8130 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8133 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8134 if (UNLIMITED_POLY (re
))
8135 from_len
= gfc_class_len_get (rse
->expr
);
8137 else if (re
->expr_type
!= EXPR_NULL
)
8138 /* Only when rhs is non-NULL use its declared type for vptr
8140 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8142 /* When the rhs is NULL use the vtab of lhs' declared type. */
8143 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8148 gfc_init_se (&se
, NULL
);
8149 se
.want_pointer
= 1;
8150 gfc_conv_expr (&se
, vptr_expr
);
8151 gfc_free_expr (vptr_expr
);
8152 gfc_add_block_to_block (block
, &se
.pre
);
8153 gcc_assert (se
.post
.head
== NULL_TREE
);
8155 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8158 if (to_len
!= NULL_TREE
)
8160 /* The _len component needs to be set. Figure how to get the
8161 value of the right-hand side. */
8162 if (from_len
== NULL_TREE
)
8164 if (rse
->string_length
!= NULL_TREE
)
8165 from_len
= rse
->string_length
;
8166 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8168 from_len
= gfc_get_expr_charlen (re
);
8169 gfc_init_se (&se
, NULL
);
8170 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8171 gfc_add_block_to_block (block
, &se
.pre
);
8172 gcc_assert (se
.post
.head
== NULL_TREE
);
8173 from_len
= gfc_evaluate_now (se
.expr
, block
);
8176 from_len
= integer_zero_node
;
8178 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8183 /* Return the _len trees only, when requested. */
8187 *from_lenp
= from_len
;
8192 /* Assign tokens for pointer components. */
8195 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8198 symbol_attribute lhs_attr
, rhs_attr
;
8199 tree tmp
, lhs_tok
, rhs_tok
;
8200 /* Flag to indicated component refs on the rhs. */
8203 lhs_attr
= gfc_caf_attr (expr1
);
8204 if (expr2
->expr_type
!= EXPR_NULL
)
8206 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8207 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8209 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8210 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8213 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8217 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8218 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8221 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8223 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8224 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8227 else if (lhs_attr
.codimension
)
8229 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8230 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8231 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8232 lhs_tok
, null_pointer_node
);
8233 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8237 /* Indentify class valued proc_pointer assignments. */
8240 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8245 while (ref
&& ref
->next
)
8248 return ref
&& ref
->type
== REF_COMPONENT
8249 && ref
->u
.c
.component
->attr
.proc_pointer
8250 && expr2
->expr_type
== EXPR_VARIABLE
8251 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8255 /* Do everything that is needed for a CLASS function expr2. */
8258 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8259 gfc_expr
*expr1
, gfc_expr
*expr2
)
8261 tree expr1_vptr
= NULL_TREE
;
8264 gfc_conv_function_expr (rse
, expr2
);
8265 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8267 if (expr1
->ts
.type
!= BT_CLASS
)
8268 rse
->expr
= gfc_class_data_get (rse
->expr
);
8271 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8274 gfc_add_block_to_block (block
, &rse
->pre
);
8275 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8276 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8278 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8279 fold_convert (TREE_TYPE (expr1_vptr
),
8280 gfc_class_vptr_get (tmp
)));
8281 rse
->expr
= gfc_class_data_get (tmp
);
8289 gfc_trans_pointer_assign (gfc_code
* code
)
8291 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8295 /* Generate code for a pointer assignment. */
8298 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8305 tree expr1_vptr
= NULL_TREE
;
8306 bool scalar
, non_proc_pointer_assign
;
8309 gfc_start_block (&block
);
8311 gfc_init_se (&lse
, NULL
);
8313 /* Usually testing whether this is not a proc pointer assignment. */
8314 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8316 /* Check whether the expression is a scalar or not; we cannot use
8317 expr1->rank as it can be nonzero for proc pointers. */
8318 ss
= gfc_walk_expr (expr1
);
8319 scalar
= ss
== gfc_ss_terminator
;
8321 gfc_free_ss_chain (ss
);
8323 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8324 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8326 gfc_add_data_component (expr2
);
8327 /* The following is required as gfc_add_data_component doesn't
8328 update ts.type if there is a tailing REF_ARRAY. */
8329 expr2
->ts
.type
= BT_DERIVED
;
8334 /* Scalar pointers. */
8335 lse
.want_pointer
= 1;
8336 gfc_conv_expr (&lse
, expr1
);
8337 gfc_init_se (&rse
, NULL
);
8338 rse
.want_pointer
= 1;
8339 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8340 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8342 gfc_conv_expr (&rse
, expr2
);
8344 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8346 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8348 lse
.expr
= gfc_class_data_get (lse
.expr
);
8351 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8352 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8353 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8356 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8357 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8358 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8361 gfc_add_block_to_block (&block
, &lse
.pre
);
8362 gfc_add_block_to_block (&block
, &rse
.pre
);
8364 /* Check character lengths if character expression. The test is only
8365 really added if -fbounds-check is enabled. Exclude deferred
8366 character length lefthand sides. */
8367 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8368 && !expr1
->ts
.deferred
8369 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8370 && !gfc_is_proc_ptr_comp (expr1
))
8372 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8373 gcc_assert (lse
.string_length
&& rse
.string_length
);
8374 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8375 lse
.string_length
, rse
.string_length
,
8379 /* The assignment to an deferred character length sets the string
8380 length to that of the rhs. */
8381 if (expr1
->ts
.deferred
)
8383 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8384 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
8385 else if (lse
.string_length
!= NULL
)
8386 gfc_add_modify (&block
, lse
.string_length
,
8387 build_int_cst (gfc_charlen_type_node
, 0));
8390 gfc_add_modify (&block
, lse
.expr
,
8391 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8393 /* Also set the tokens for pointer components in derived typed
8395 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8396 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8398 gfc_add_block_to_block (&block
, &rse
.post
);
8399 gfc_add_block_to_block (&block
, &lse
.post
);
8406 tree strlen_rhs
= NULL_TREE
;
8408 /* Array pointer. Find the last reference on the LHS and if it is an
8409 array section ref, we're dealing with bounds remapping. In this case,
8410 set it to AR_FULL so that gfc_conv_expr_descriptor does
8411 not see it and process the bounds remapping afterwards explicitly. */
8412 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8413 if (!remap
->next
&& remap
->type
== REF_ARRAY
8414 && remap
->u
.ar
.type
== AR_SECTION
)
8416 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8418 gfc_init_se (&lse
, NULL
);
8420 lse
.descriptor_only
= 1;
8421 gfc_conv_expr_descriptor (&lse
, expr1
);
8422 strlen_lhs
= lse
.string_length
;
8425 if (expr2
->expr_type
== EXPR_NULL
)
8427 /* Just set the data pointer to null. */
8428 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8430 else if (rank_remap
)
8432 /* If we are rank-remapping, just get the RHS's descriptor and
8433 process this later on. */
8434 gfc_init_se (&rse
, NULL
);
8435 rse
.direct_byref
= 1;
8436 rse
.byref_noassign
= 1;
8438 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8439 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8441 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8443 tree bound
[GFC_MAX_DIMENSIONS
];
8446 for (i
= 0; i
< expr2
->rank
; i
++)
8447 bound
[i
] = NULL_TREE
;
8448 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8449 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8451 GFC_ARRAY_POINTER_CONT
, false);
8452 tmp
= gfc_create_var (tmp
, "ptrtemp");
8453 rse
.descriptor_only
= 0;
8455 rse
.direct_byref
= 1;
8456 gfc_conv_expr_descriptor (&rse
, expr2
);
8457 strlen_rhs
= rse
.string_length
;
8462 gfc_conv_expr_descriptor (&rse
, expr2
);
8463 strlen_rhs
= rse
.string_length
;
8464 if (expr1
->ts
.type
== BT_CLASS
)
8465 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8470 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8472 /* Assign directly to the LHS's descriptor. */
8473 lse
.descriptor_only
= 0;
8474 lse
.direct_byref
= 1;
8475 gfc_conv_expr_descriptor (&lse
, expr2
);
8476 strlen_rhs
= lse
.string_length
;
8478 if (expr1
->ts
.type
== BT_CLASS
)
8480 rse
.expr
= NULL_TREE
;
8481 rse
.string_length
= NULL_TREE
;
8482 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8488 /* If the target is not a whole array, use the target array
8489 reference for remap. */
8490 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8491 if (remap
->type
== REF_ARRAY
8492 && remap
->u
.ar
.type
== AR_FULL
8497 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8499 gfc_init_se (&rse
, NULL
);
8500 rse
.want_pointer
= 1;
8501 gfc_conv_function_expr (&rse
, expr2
);
8502 if (expr1
->ts
.type
!= BT_CLASS
)
8504 rse
.expr
= gfc_class_data_get (rse
.expr
);
8505 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8506 /* Set the lhs span. */
8507 tmp
= TREE_TYPE (rse
.expr
);
8508 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8509 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8510 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8514 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8517 gfc_add_block_to_block (&block
, &rse
.pre
);
8518 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8519 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8521 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8522 fold_convert (TREE_TYPE (expr1_vptr
),
8523 gfc_class_vptr_get (tmp
)));
8524 rse
.expr
= gfc_class_data_get (tmp
);
8525 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8530 /* Assign to a temporary descriptor and then copy that
8531 temporary to the pointer. */
8532 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8533 lse
.descriptor_only
= 0;
8535 lse
.direct_byref
= 1;
8536 gfc_conv_expr_descriptor (&lse
, expr2
);
8537 strlen_rhs
= lse
.string_length
;
8538 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8541 gfc_add_block_to_block (&block
, &lse
.pre
);
8543 gfc_add_block_to_block (&block
, &rse
.pre
);
8545 /* If we do bounds remapping, update LHS descriptor accordingly. */
8549 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8553 /* Do rank remapping. We already have the RHS's descriptor
8554 converted in rse and now have to build the correct LHS
8555 descriptor for it. */
8557 tree dtype
, data
, span
;
8559 tree lbound
, ubound
;
8562 dtype
= gfc_conv_descriptor_dtype (desc
);
8563 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8564 gfc_add_modify (&block
, dtype
, tmp
);
8566 /* Copy data pointer. */
8567 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8568 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8570 /* Copy the span. */
8571 if (TREE_CODE (rse
.expr
) == VAR_DECL
8572 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8573 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8576 tmp
= TREE_TYPE (rse
.expr
);
8577 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8578 span
= fold_convert (gfc_array_index_type
, tmp
);
8580 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8582 /* Copy offset but adjust it such that it would correspond
8583 to a lbound of zero. */
8584 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8585 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8587 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8589 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8591 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8592 gfc_array_index_type
, stride
, lbound
);
8593 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8594 gfc_array_index_type
, offs
, tmp
);
8596 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8598 /* Set the bounds as declared for the LHS and calculate strides as
8599 well as another offset update accordingly. */
8600 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8602 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8607 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8609 /* Convert declared bounds. */
8610 gfc_init_se (&lower_se
, NULL
);
8611 gfc_init_se (&upper_se
, NULL
);
8612 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8613 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8615 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8616 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8618 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8619 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8621 lbound
= gfc_evaluate_now (lbound
, &block
);
8622 ubound
= gfc_evaluate_now (ubound
, &block
);
8624 gfc_add_block_to_block (&block
, &lower_se
.post
);
8625 gfc_add_block_to_block (&block
, &upper_se
.post
);
8627 /* Set bounds in descriptor. */
8628 gfc_conv_descriptor_lbound_set (&block
, desc
,
8629 gfc_rank_cst
[dim
], lbound
);
8630 gfc_conv_descriptor_ubound_set (&block
, desc
,
8631 gfc_rank_cst
[dim
], ubound
);
8634 stride
= gfc_evaluate_now (stride
, &block
);
8635 gfc_conv_descriptor_stride_set (&block
, desc
,
8636 gfc_rank_cst
[dim
], stride
);
8638 /* Update offset. */
8639 offs
= gfc_conv_descriptor_offset_get (desc
);
8640 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8641 gfc_array_index_type
, lbound
, stride
);
8642 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8643 gfc_array_index_type
, offs
, tmp
);
8644 offs
= gfc_evaluate_now (offs
, &block
);
8645 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8647 /* Update stride. */
8648 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8649 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8650 gfc_array_index_type
, stride
, tmp
);
8655 /* Bounds remapping. Just shift the lower bounds. */
8657 gcc_assert (expr1
->rank
== expr2
->rank
);
8659 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8663 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8664 gfc_init_se (&lbound_se
, NULL
);
8665 if (remap
->u
.ar
.start
[dim
])
8667 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8668 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8671 /* This remap arises from a target that is not a whole
8672 array. The start expressions will be NULL but we need
8673 the lbounds to be one. */
8674 lbound_se
.expr
= gfc_index_one_node
;
8675 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8676 dim
, lbound_se
.expr
);
8677 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8682 /* Check string lengths if applicable. The check is only really added
8683 to the output code if -fbounds-check is enabled. */
8684 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8686 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8687 gcc_assert (strlen_lhs
&& strlen_rhs
);
8688 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8689 strlen_lhs
, strlen_rhs
, &block
);
8692 /* If rank remapping was done, check with -fcheck=bounds that
8693 the target is at least as large as the pointer. */
8694 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8700 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8701 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8703 lsize
= gfc_evaluate_now (lsize
, &block
);
8704 rsize
= gfc_evaluate_now (rsize
, &block
);
8705 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
8708 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8709 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8713 gfc_add_block_to_block (&block
, &lse
.post
);
8715 gfc_add_block_to_block (&block
, &rse
.post
);
8718 return gfc_finish_block (&block
);
8722 /* Makes sure se is suitable for passing as a function string parameter. */
8723 /* TODO: Need to check all callers of this function. It may be abused. */
8726 gfc_conv_string_parameter (gfc_se
* se
)
8730 if (TREE_CODE (se
->expr
) == STRING_CST
)
8732 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8733 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8737 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8739 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8741 type
= TREE_TYPE (se
->expr
);
8742 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8746 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8748 type
= build_pointer_type (type
);
8749 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8753 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8757 /* Generate code for assignment of scalar variables. Includes character
8758 strings and derived types with allocatable components.
8759 If you know that the LHS has no allocations, set dealloc to false.
8761 DEEP_COPY has no effect if the typespec TS is not a derived type with
8762 allocatable components. Otherwise, if it is set, an explicit copy of each
8763 allocatable component is made. This is necessary as a simple copy of the
8764 whole object would copy array descriptors as is, so that the lhs's
8765 allocatable components would point to the rhs's after the assignment.
8766 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8767 necessary if the rhs is a non-pointer function, as the allocatable components
8768 are not accessible by other means than the function's result after the
8769 function has returned. It is even more subtle when temporaries are involved,
8770 as the two following examples show:
8771 1. When we evaluate an array constructor, a temporary is created. Thus
8772 there is theoretically no alias possible. However, no deep copy is
8773 made for this temporary, so that if the constructor is made of one or
8774 more variable with allocatable components, those components still point
8775 to the variable's: DEEP_COPY should be set for the assignment from the
8776 temporary to the lhs in that case.
8777 2. When assigning a scalar to an array, we evaluate the scalar value out
8778 of the loop, store it into a temporary variable, and assign from that.
8779 In that case, deep copying when assigning to the temporary would be a
8780 waste of resources; however deep copies should happen when assigning from
8781 the temporary to each array element: again DEEP_COPY should be set for
8782 the assignment from the temporary to the lhs. */
8785 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8786 bool deep_copy
, bool dealloc
, bool in_coarray
)
8792 gfc_init_block (&block
);
8794 if (ts
.type
== BT_CHARACTER
)
8799 if (lse
->string_length
!= NULL_TREE
)
8801 gfc_conv_string_parameter (lse
);
8802 gfc_add_block_to_block (&block
, &lse
->pre
);
8803 llen
= lse
->string_length
;
8806 if (rse
->string_length
!= NULL_TREE
)
8808 gfc_conv_string_parameter (rse
);
8809 gfc_add_block_to_block (&block
, &rse
->pre
);
8810 rlen
= rse
->string_length
;
8813 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8814 rse
->expr
, ts
.kind
);
8816 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8818 tree tmp_var
= NULL_TREE
;
8821 /* Are the rhs and the lhs the same? */
8824 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8825 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8826 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8827 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8830 /* Deallocate the lhs allocated components as long as it is not
8831 the same as the rhs. This must be done following the assignment
8832 to prevent deallocating data that could be used in the rhs
8836 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8837 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8839 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8841 gfc_add_expr_to_block (&lse
->post
, tmp
);
8844 gfc_add_block_to_block (&block
, &rse
->pre
);
8845 gfc_add_block_to_block (&block
, &lse
->pre
);
8847 gfc_add_modify (&block
, lse
->expr
,
8848 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8850 /* Restore pointer address of coarray components. */
8851 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8853 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8854 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8856 gfc_add_expr_to_block (&block
, tmp
);
8859 /* Do a deep copy if the rhs is a variable, if it is not the
8863 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8864 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
8865 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
8867 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8869 gfc_add_expr_to_block (&block
, tmp
);
8872 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8874 gfc_add_block_to_block (&block
, &lse
->pre
);
8875 gfc_add_block_to_block (&block
, &rse
->pre
);
8876 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8877 TREE_TYPE (lse
->expr
), rse
->expr
);
8878 gfc_add_modify (&block
, lse
->expr
, tmp
);
8882 gfc_add_block_to_block (&block
, &lse
->pre
);
8883 gfc_add_block_to_block (&block
, &rse
->pre
);
8885 gfc_add_modify (&block
, lse
->expr
,
8886 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8889 gfc_add_block_to_block (&block
, &lse
->post
);
8890 gfc_add_block_to_block (&block
, &rse
->post
);
8892 return gfc_finish_block (&block
);
8896 /* There are quite a lot of restrictions on the optimisation in using an
8897 array function assign without a temporary. */
8900 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8903 bool seen_array_ref
;
8905 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8907 /* Play it safe with class functions assigned to a derived type. */
8908 if (gfc_is_class_array_function (expr2
)
8909 && expr1
->ts
.type
== BT_DERIVED
)
8912 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8913 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8916 /* Elemental functions are scalarized so that they don't need a
8917 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8918 they would need special treatment in gfc_trans_arrayfunc_assign. */
8919 if (expr2
->value
.function
.esym
!= NULL
8920 && expr2
->value
.function
.esym
->attr
.elemental
)
8923 /* Need a temporary if rhs is not FULL or a contiguous section. */
8924 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8927 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8928 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8931 /* Functions returning pointers or allocatables need temporaries. */
8932 c
= expr2
->value
.function
.esym
8933 ? (expr2
->value
.function
.esym
->attr
.pointer
8934 || expr2
->value
.function
.esym
->attr
.allocatable
)
8935 : (expr2
->symtree
->n
.sym
->attr
.pointer
8936 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8940 /* Character array functions need temporaries unless the
8941 character lengths are the same. */
8942 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8944 if (expr1
->ts
.u
.cl
->length
== NULL
8945 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8948 if (expr2
->ts
.u
.cl
->length
== NULL
8949 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8952 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8953 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8957 /* Check that no LHS component references appear during an array
8958 reference. This is needed because we do not have the means to
8959 span any arbitrary stride with an array descriptor. This check
8960 is not needed for the rhs because the function result has to be
8962 seen_array_ref
= false;
8963 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8965 if (ref
->type
== REF_ARRAY
)
8966 seen_array_ref
= true;
8967 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8971 /* Check for a dependency. */
8972 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8973 expr2
->value
.function
.esym
,
8974 expr2
->value
.function
.actual
,
8978 /* If we have reached here with an intrinsic function, we do not
8979 need a temporary except in the particular case that reallocation
8980 on assignment is active and the lhs is allocatable and a target. */
8981 if (expr2
->value
.function
.isym
)
8982 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8984 /* If the LHS is a dummy, we need a temporary if it is not
8986 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8989 /* If the lhs has been host_associated, is in common, a pointer or is
8990 a target and the function is not using a RESULT variable, aliasing
8991 can occur and a temporary is needed. */
8992 if ((sym
->attr
.host_assoc
8993 || sym
->attr
.in_common
8994 || sym
->attr
.pointer
8995 || sym
->attr
.cray_pointee
8996 || sym
->attr
.target
)
8997 && expr2
->symtree
!= NULL
8998 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9001 /* A PURE function can unconditionally be called without a temporary. */
9002 if (expr2
->value
.function
.esym
!= NULL
9003 && expr2
->value
.function
.esym
->attr
.pure
)
9006 /* Implicit_pure functions are those which could legally be declared
9008 if (expr2
->value
.function
.esym
!= NULL
9009 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9012 if (!sym
->attr
.use_assoc
9013 && !sym
->attr
.in_common
9014 && !sym
->attr
.pointer
9015 && !sym
->attr
.target
9016 && !sym
->attr
.cray_pointee
9017 && expr2
->value
.function
.esym
)
9019 /* A temporary is not needed if the function is not contained and
9020 the variable is local or host associated and not a pointer or
9022 if (!expr2
->value
.function
.esym
->attr
.contained
)
9025 /* A temporary is not needed if the lhs has never been host
9026 associated and the procedure is contained. */
9027 else if (!sym
->attr
.host_assoc
)
9030 /* A temporary is not needed if the variable is local and not
9031 a pointer, a target or a result. */
9033 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9037 /* Default to temporary use. */
9042 /* Provide the loop info so that the lhs descriptor can be built for
9043 reallocatable assignments from extrinsic function calls. */
9046 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9049 /* Signal that the function call should not be made by
9050 gfc_conv_loop_setup. */
9051 se
->ss
->is_alloc_lhs
= 1;
9052 gfc_init_loopinfo (loop
);
9053 gfc_add_ss_to_loop (loop
, *ss
);
9054 gfc_add_ss_to_loop (loop
, se
->ss
);
9055 gfc_conv_ss_startstride (loop
);
9056 gfc_conv_loop_setup (loop
, where
);
9057 gfc_copy_loopinfo_to_se (se
, loop
);
9058 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9059 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9060 se
->ss
->is_alloc_lhs
= 0;
9064 /* For assignment to a reallocatable lhs from intrinsic functions,
9065 replace the se.expr (ie. the result) with a temporary descriptor.
9066 Null the data field so that the library allocates space for the
9067 result. Free the data of the original descriptor after the function,
9068 in case it appears in an argument expression and transfer the
9069 result to the original descriptor. */
9072 fcncall_realloc_result (gfc_se
*se
, int rank
)
9081 /* Use the allocation done by the library. Substitute the lhs
9082 descriptor with a copy, whose data field is nulled.*/
9083 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9084 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9085 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9087 /* Unallocated, the descriptor does not have a dtype. */
9088 tmp
= gfc_conv_descriptor_dtype (desc
);
9089 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9091 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9092 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9093 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9095 /* Free the lhs after the function call and copy the result data to
9096 the lhs descriptor. */
9097 tmp
= gfc_conv_descriptor_data_get (desc
);
9098 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9099 logical_type_node
, tmp
,
9100 build_int_cst (TREE_TYPE (tmp
), 0));
9101 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9102 tmp
= gfc_call_free (tmp
);
9103 gfc_add_expr_to_block (&se
->post
, tmp
);
9105 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9106 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9108 /* Check that the shapes are the same between lhs and expression. */
9109 for (n
= 0 ; n
< rank
; n
++)
9112 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9113 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9114 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9115 gfc_array_index_type
, tmp
, tmp1
);
9116 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9117 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9118 gfc_array_index_type
, tmp
, tmp1
);
9119 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9120 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9121 gfc_array_index_type
, tmp
, tmp1
);
9122 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9123 logical_type_node
, tmp
,
9124 gfc_index_zero_node
);
9125 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9126 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9127 logical_type_node
, tmp
,
9131 /* 'zero_cond' being true is equal to lhs not being allocated or the
9132 shapes being different. */
9133 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9135 /* Now reset the bounds returned from the function call to bounds based
9136 on the lhs lbounds, except where the lhs is not allocated or the shapes
9137 of 'variable and 'expr' are different. Set the offset accordingly. */
9138 offset
= gfc_index_zero_node
;
9139 for (n
= 0 ; n
< rank
; n
++)
9143 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9144 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9145 gfc_array_index_type
, zero_cond
,
9146 gfc_index_one_node
, lbound
);
9147 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9149 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9150 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9151 gfc_array_index_type
, tmp
, lbound
);
9152 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9153 gfc_rank_cst
[n
], lbound
);
9154 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9155 gfc_rank_cst
[n
], tmp
);
9157 /* Set stride and accumulate the offset. */
9158 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9159 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9160 gfc_rank_cst
[n
], tmp
);
9161 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9162 gfc_array_index_type
, lbound
, tmp
);
9163 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9164 gfc_array_index_type
, offset
, tmp
);
9165 offset
= gfc_evaluate_now (offset
, &se
->post
);
9168 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9173 /* Try to translate array(:) = func (...), where func is a transformational
9174 array function, without using a temporary. Returns NULL if this isn't the
9178 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9182 gfc_component
*comp
= NULL
;
9185 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9188 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9190 comp
= gfc_get_proc_ptr_comp (expr2
);
9191 gcc_assert (expr2
->value
.function
.isym
9192 || (comp
&& comp
->attr
.dimension
)
9193 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9194 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
9196 gfc_init_se (&se
, NULL
);
9197 gfc_start_block (&se
.pre
);
9198 se
.want_pointer
= 1;
9200 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9202 if (expr1
->ts
.type
== BT_DERIVED
9203 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9206 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9208 gfc_add_expr_to_block (&se
.pre
, tmp
);
9211 se
.direct_byref
= 1;
9212 se
.ss
= gfc_walk_expr (expr2
);
9213 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9215 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9216 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9217 Clearly, this cannot be done for an allocatable function result, since
9218 the shape of the result is unknown and, in any case, the function must
9219 correctly take care of the reallocation internally. For intrinsic
9220 calls, the array data is freed and the library takes care of allocation.
9221 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9223 if (flag_realloc_lhs
9224 && gfc_is_reallocatable_lhs (expr1
)
9225 && !gfc_expr_attr (expr1
).codimension
9226 && !gfc_is_coindexed (expr1
)
9227 && !(expr2
->value
.function
.esym
9228 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9230 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9232 if (!expr2
->value
.function
.isym
)
9234 ss
= gfc_walk_expr (expr1
);
9235 gcc_assert (ss
!= gfc_ss_terminator
);
9237 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9238 ss
->is_alloc_lhs
= 1;
9241 fcncall_realloc_result (&se
, expr1
->rank
);
9244 gfc_conv_function_expr (&se
, expr2
);
9245 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9248 gfc_cleanup_loop (&loop
);
9250 gfc_free_ss_chain (se
.ss
);
9252 return gfc_finish_block (&se
.pre
);
9256 /* Try to efficiently translate array(:) = 0. Return NULL if this
9260 gfc_trans_zero_assign (gfc_expr
* expr
)
9262 tree dest
, len
, type
;
9266 sym
= expr
->symtree
->n
.sym
;
9267 dest
= gfc_get_symbol_decl (sym
);
9269 type
= TREE_TYPE (dest
);
9270 if (POINTER_TYPE_P (type
))
9271 type
= TREE_TYPE (type
);
9272 if (!GFC_ARRAY_TYPE_P (type
))
9275 /* Determine the length of the array. */
9276 len
= GFC_TYPE_ARRAY_SIZE (type
);
9277 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9280 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9281 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9282 fold_convert (gfc_array_index_type
, tmp
));
9284 /* If we are zeroing a local array avoid taking its address by emitting
9286 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9287 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9288 dest
, build_constructor (TREE_TYPE (dest
),
9291 /* Convert arguments to the correct types. */
9292 dest
= fold_convert (pvoid_type_node
, dest
);
9293 len
= fold_convert (size_type_node
, len
);
9295 /* Construct call to __builtin_memset. */
9296 tmp
= build_call_expr_loc (input_location
,
9297 builtin_decl_explicit (BUILT_IN_MEMSET
),
9298 3, dest
, integer_zero_node
, len
);
9299 return fold_convert (void_type_node
, tmp
);
9303 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9304 that constructs the call to __builtin_memcpy. */
9307 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9311 /* Convert arguments to the correct types. */
9312 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9313 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9315 dst
= fold_convert (pvoid_type_node
, dst
);
9317 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9318 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9320 src
= fold_convert (pvoid_type_node
, src
);
9322 len
= fold_convert (size_type_node
, len
);
9324 /* Construct call to __builtin_memcpy. */
9325 tmp
= build_call_expr_loc (input_location
,
9326 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9328 return fold_convert (void_type_node
, tmp
);
9332 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9333 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9334 source/rhs, both are gfc_full_array_ref_p which have been checked for
9338 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9340 tree dst
, dlen
, dtype
;
9341 tree src
, slen
, stype
;
9344 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9345 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9347 dtype
= TREE_TYPE (dst
);
9348 if (POINTER_TYPE_P (dtype
))
9349 dtype
= TREE_TYPE (dtype
);
9350 stype
= TREE_TYPE (src
);
9351 if (POINTER_TYPE_P (stype
))
9352 stype
= TREE_TYPE (stype
);
9354 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9357 /* Determine the lengths of the arrays. */
9358 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9359 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9361 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9362 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9363 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9365 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9366 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9368 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9369 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9370 slen
, fold_convert (gfc_array_index_type
, tmp
));
9372 /* Sanity check that they are the same. This should always be
9373 the case, as we should already have checked for conformance. */
9374 if (!tree_int_cst_equal (slen
, dlen
))
9377 return gfc_build_memcpy_call (dst
, src
, dlen
);
9381 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9382 this can't be done. EXPR1 is the destination/lhs for which
9383 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9386 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9388 unsigned HOST_WIDE_INT nelem
;
9394 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9398 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9399 dtype
= TREE_TYPE (dst
);
9400 if (POINTER_TYPE_P (dtype
))
9401 dtype
= TREE_TYPE (dtype
);
9402 if (!GFC_ARRAY_TYPE_P (dtype
))
9405 /* Determine the lengths of the array. */
9406 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9407 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9410 /* Confirm that the constructor is the same size. */
9411 if (compare_tree_int (len
, nelem
) != 0)
9414 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9415 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9416 fold_convert (gfc_array_index_type
, tmp
));
9418 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9419 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9421 stype
= TREE_TYPE (src
);
9422 if (POINTER_TYPE_P (stype
))
9423 stype
= TREE_TYPE (stype
);
9425 return gfc_build_memcpy_call (dst
, src
, len
);
9429 /* Tells whether the expression is to be treated as a variable reference. */
9432 gfc_expr_is_variable (gfc_expr
*expr
)
9435 gfc_component
*comp
;
9436 gfc_symbol
*func_ifc
;
9438 if (expr
->expr_type
== EXPR_VARIABLE
)
9441 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9444 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9445 return gfc_expr_is_variable (arg
);
9448 /* A data-pointer-returning function should be considered as a variable
9450 if (expr
->expr_type
== EXPR_FUNCTION
9451 && expr
->ref
== NULL
)
9453 if (expr
->value
.function
.isym
!= NULL
)
9456 if (expr
->value
.function
.esym
!= NULL
)
9458 func_ifc
= expr
->value
.function
.esym
;
9463 gcc_assert (expr
->symtree
);
9464 func_ifc
= expr
->symtree
->n
.sym
;
9471 comp
= gfc_get_proc_ptr_comp (expr
);
9472 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9475 func_ifc
= comp
->ts
.interface
;
9479 if (expr
->expr_type
== EXPR_COMPCALL
)
9481 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9482 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9489 gcc_assert (func_ifc
->attr
.function
9490 && func_ifc
->result
!= NULL
);
9491 return func_ifc
->result
->attr
.pointer
;
9495 /* Is the lhs OK for automatic reallocation? */
9498 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9502 /* An allocatable variable with no reference. */
9503 if (expr
->symtree
->n
.sym
->attr
.allocatable
9507 /* All that can be left are allocatable components. However, we do
9508 not check for allocatable components here because the expression
9509 could be an allocatable component of a pointer component. */
9510 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9511 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9514 /* Find an allocatable component ref last. */
9515 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9516 if (ref
->type
== REF_COMPONENT
9518 && ref
->u
.c
.component
->attr
.allocatable
)
9525 /* Allocate or reallocate scalar lhs, as necessary. */
9528 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9543 if (!expr1
|| expr1
->rank
)
9546 if (!expr2
|| expr2
->rank
)
9549 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9550 if (ref
->type
== REF_SUBSTRING
)
9553 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9555 /* Since this is a scalar lhs, we can afford to do this. That is,
9556 there is no risk of side effects being repeated. */
9557 gfc_init_se (&lse
, NULL
);
9558 lse
.want_pointer
= 1;
9559 gfc_conv_expr (&lse
, expr1
);
9561 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9562 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9564 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9565 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9566 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9568 tmp
= build3_v (COND_EXPR
, cond
,
9569 build1_v (GOTO_EXPR
, jump_label1
),
9570 build_empty_stmt (input_location
));
9571 gfc_add_expr_to_block (block
, tmp
);
9573 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9575 /* Use the rhs string length and the lhs element size. */
9576 size
= string_length
;
9577 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9578 tmp
= TYPE_SIZE_UNIT (tmp
);
9579 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9580 TREE_TYPE (tmp
), tmp
,
9581 fold_convert (TREE_TYPE (tmp
), size
));
9585 /* Otherwise use the length in bytes of the rhs. */
9586 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9587 size_in_bytes
= size
;
9590 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9591 size_in_bytes
, size_one_node
);
9593 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9595 tree caf_decl
, token
;
9597 symbol_attribute attr
;
9599 gfc_clear_attr (&attr
);
9600 gfc_init_se (&caf_se
, NULL
);
9602 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9603 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9605 gfc_add_block_to_block (block
, &caf_se
.pre
);
9606 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9607 gfc_build_addr_expr (NULL_TREE
, token
),
9608 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9611 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9613 tmp
= build_call_expr_loc (input_location
,
9614 builtin_decl_explicit (BUILT_IN_CALLOC
),
9615 2, build_one_cst (size_type_node
),
9617 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9618 gfc_add_modify (block
, lse
.expr
, tmp
);
9622 tmp
= build_call_expr_loc (input_location
,
9623 builtin_decl_explicit (BUILT_IN_MALLOC
),
9625 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9626 gfc_add_modify (block
, lse
.expr
, tmp
);
9629 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9631 /* Deferred characters need checking for lhs and rhs string
9632 length. Other deferred parameter variables will have to
9634 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9635 gfc_add_expr_to_block (block
, tmp
);
9637 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9638 gfc_add_expr_to_block (block
, tmp
);
9640 /* For a deferred length character, reallocate if lengths of lhs and
9641 rhs are different. */
9642 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9644 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9645 lse
.string_length
, size
);
9646 /* Jump past the realloc if the lengths are the same. */
9647 tmp
= build3_v (COND_EXPR
, cond
,
9648 build1_v (GOTO_EXPR
, jump_label2
),
9649 build_empty_stmt (input_location
));
9650 gfc_add_expr_to_block (block
, tmp
);
9651 tmp
= build_call_expr_loc (input_location
,
9652 builtin_decl_explicit (BUILT_IN_REALLOC
),
9653 2, fold_convert (pvoid_type_node
, lse
.expr
),
9655 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9656 gfc_add_modify (block
, lse
.expr
, tmp
);
9657 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9658 gfc_add_expr_to_block (block
, tmp
);
9660 /* Update the lhs character length. */
9661 size
= string_length
;
9662 gfc_add_modify (block
, lse
.string_length
, size
);
9666 /* Check for assignments of the type
9670 to make sure we do not check for reallocation unneccessarily. */
9674 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9676 gfc_actual_arglist
*a
;
9679 switch (expr2
->expr_type
)
9682 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9685 if (expr2
->value
.function
.esym
9686 && expr2
->value
.function
.esym
->attr
.elemental
)
9688 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9691 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9696 else if (expr2
->value
.function
.isym
9697 && expr2
->value
.function
.isym
->elemental
)
9699 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9702 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9711 switch (expr2
->value
.op
.op
)
9714 case INTRINSIC_UPLUS
:
9715 case INTRINSIC_UMINUS
:
9716 case INTRINSIC_PARENTHESES
:
9717 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9719 case INTRINSIC_PLUS
:
9720 case INTRINSIC_MINUS
:
9721 case INTRINSIC_TIMES
:
9722 case INTRINSIC_DIVIDE
:
9723 case INTRINSIC_POWER
:
9727 case INTRINSIC_NEQV
:
9734 case INTRINSIC_EQ_OS
:
9735 case INTRINSIC_NE_OS
:
9736 case INTRINSIC_GT_OS
:
9737 case INTRINSIC_GE_OS
:
9738 case INTRINSIC_LT_OS
:
9739 case INTRINSIC_LE_OS
:
9741 e1
= expr2
->value
.op
.op1
;
9742 e2
= expr2
->value
.op
.op2
;
9744 if (e1
->rank
== 0 && e2
->rank
> 0)
9745 return is_runtime_conformable (expr1
, e2
);
9746 else if (e1
->rank
> 0 && e2
->rank
== 0)
9747 return is_runtime_conformable (expr1
, e1
);
9748 else if (e1
->rank
> 0 && e2
->rank
> 0)
9749 return is_runtime_conformable (expr1
, e1
)
9750 && is_runtime_conformable (expr1
, e2
);
9768 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9769 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
9772 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
9773 vec
<tree
, va_gc
> *args
= NULL
;
9775 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9778 /* Generate allocation of the lhs. */
9784 tmp
= gfc_vptr_size_get (vptr
);
9785 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9786 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9787 gfc_init_block (&alloc
);
9788 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
9789 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9790 logical_type_node
, class_han
,
9791 build_int_cst (prvoid_type_node
, 0));
9792 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
9794 PRED_FORTRAN_FAIL_ALLOC
),
9795 gfc_finish_block (&alloc
),
9796 build_empty_stmt (input_location
));
9797 gfc_add_expr_to_block (&lse
->pre
, tmp
);
9800 fcn
= gfc_vptr_copy_get (vptr
);
9802 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9803 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9806 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9807 || INDIRECT_REF_P (tmp
)
9808 || (rhs
->ts
.type
== BT_DERIVED
9809 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9810 && !rhs
->ts
.u
.derived
->attr
.pointer
9811 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9812 || (UNLIMITED_POLY (rhs
)
9813 && !CLASS_DATA (rhs
)->attr
.pointer
9814 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9815 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9817 vec_safe_push (args
, tmp
);
9818 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9819 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9820 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9821 || INDIRECT_REF_P (tmp
)
9822 || (lhs
->ts
.type
== BT_DERIVED
9823 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9824 && !lhs
->ts
.u
.derived
->attr
.pointer
9825 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9826 || (UNLIMITED_POLY (lhs
)
9827 && !CLASS_DATA (lhs
)->attr
.pointer
9828 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9829 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9831 vec_safe_push (args
, tmp
);
9833 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9835 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9838 vec_safe_push (args
, from_len
);
9839 vec_safe_push (args
, to_len
);
9840 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9842 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9843 logical_type_node
, from_len
,
9845 return fold_build3_loc (input_location
, COND_EXPR
,
9846 void_type_node
, tmp
,
9854 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9855 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9857 gfc_init_block (&tblock
);
9858 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9859 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9860 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9861 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9862 /* When coming from a ptr_copy lhs and rhs are swapped. */
9863 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9864 fold_convert (TREE_TYPE (rhst
), tmp
));
9865 return gfc_finish_block (&tblock
);
9869 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9870 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9871 init_flag indicates initialization expressions and dealloc that no
9872 deallocate prior assignment is needed (if in doubt, set true).
9873 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9874 routine instead of a pointer assignment. Alias resolution is only done,
9875 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9876 where it is known, that newly allocated memory on the lhs can never be
9877 an alias of the rhs. */
9880 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9881 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9886 gfc_ss
*lss_section
;
9893 bool scalar_to_array
;
9896 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
9897 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9898 bool is_poly_assign
;
9900 /* Assignment of the form lhs = rhs. */
9901 gfc_start_block (&block
);
9903 gfc_init_se (&lse
, NULL
);
9904 gfc_init_se (&rse
, NULL
);
9907 lss
= gfc_walk_expr (expr1
);
9908 if (gfc_is_reallocatable_lhs (expr1
)
9909 && !(expr2
->expr_type
== EXPR_FUNCTION
9910 && expr2
->value
.function
.isym
!= NULL
))
9911 lss
->is_alloc_lhs
= 1;
9914 if ((expr1
->ts
.type
== BT_DERIVED
)
9915 && (gfc_is_class_array_function (expr2
)
9916 || gfc_is_alloc_class_scalar_function (expr2
)))
9917 expr2
->must_finalize
= 1;
9919 /* Checking whether a class assignment is desired is quite complicated and
9920 needed at two locations, so do it once only before the information is
9922 lhs_attr
= gfc_expr_attr (expr1
);
9923 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
9924 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9925 && (expr1
->ts
.type
== BT_CLASS
9926 || gfc_is_class_array_ref (expr1
, NULL
)
9927 || gfc_is_class_scalar_expr (expr1
)
9928 || gfc_is_class_array_ref (expr2
, NULL
)
9929 || gfc_is_class_scalar_expr (expr2
));
9932 /* Only analyze the expressions for coarray properties, when in coarray-lib
9934 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9936 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
9937 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
9940 if (lss
!= gfc_ss_terminator
)
9942 /* The assignment needs scalarization. */
9945 /* Find a non-scalar SS from the lhs. */
9946 while (lss_section
!= gfc_ss_terminator
9947 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9948 lss_section
= lss_section
->next
;
9950 gcc_assert (lss_section
!= gfc_ss_terminator
);
9952 /* Initialize the scalarizer. */
9953 gfc_init_loopinfo (&loop
);
9956 rss
= gfc_walk_expr (expr2
);
9957 if (rss
== gfc_ss_terminator
)
9958 /* The rhs is scalar. Add a ss for the expression. */
9959 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9960 /* When doing a class assign, then the handle to the rhs needs to be a
9961 pointer to allow for polymorphism. */
9962 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
9963 rss
->info
->type
= GFC_SS_REFERENCE
;
9965 /* Associate the SS with the loop. */
9966 gfc_add_ss_to_loop (&loop
, lss
);
9967 gfc_add_ss_to_loop (&loop
, rss
);
9969 /* Calculate the bounds of the scalarization. */
9970 gfc_conv_ss_startstride (&loop
);
9971 /* Enable loop reversal. */
9972 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9973 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9974 /* Resolve any data dependencies in the statement. */
9976 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9977 /* Setup the scalarizing loops. */
9978 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9980 /* Setup the gfc_se structures. */
9981 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9982 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9985 gfc_mark_ss_chain_used (rss
, 1);
9986 if (loop
.temp_ss
== NULL
)
9989 gfc_mark_ss_chain_used (lss
, 1);
9993 lse
.ss
= loop
.temp_ss
;
9994 gfc_mark_ss_chain_used (lss
, 3);
9995 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9998 /* Allow the scalarizer to workshare array assignments. */
9999 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10000 == OMPWS_WORKSHARE_FLAG
10001 && loop
.temp_ss
== NULL
)
10003 maybe_workshare
= true;
10004 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10007 /* Start the scalarized loop body. */
10008 gfc_start_scalarized_body (&loop
, &body
);
10011 gfc_init_block (&body
);
10013 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10015 /* Translate the expression. */
10016 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10017 && lhs_caf_attr
.codimension
;
10018 gfc_conv_expr (&rse
, expr2
);
10020 /* Deal with the case of a scalar class function assigned to a derived type. */
10021 if (gfc_is_alloc_class_scalar_function (expr2
)
10022 && expr1
->ts
.type
== BT_DERIVED
)
10024 rse
.expr
= gfc_class_data_get (rse
.expr
);
10025 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10028 /* Stabilize a string length for temporaries. */
10029 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10030 && !(VAR_P (rse
.string_length
)
10031 || TREE_CODE (rse
.string_length
) == PARM_DECL
10032 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10033 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10034 else if (expr2
->ts
.type
== BT_CHARACTER
)
10035 string_length
= rse
.string_length
;
10037 string_length
= NULL_TREE
;
10041 gfc_conv_tmp_array_ref (&lse
);
10042 if (expr2
->ts
.type
== BT_CHARACTER
)
10043 lse
.string_length
= string_length
;
10047 gfc_conv_expr (&lse
, expr1
);
10048 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10050 && gfc_expr_attr (expr1
).allocatable
10057 tmp
= INDIRECT_REF_P (lse
.expr
)
10058 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10060 /* We should only get array references here. */
10061 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10062 || TREE_CODE (tmp
) == ARRAY_REF
);
10064 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10065 or the array itself(ARRAY_REF). */
10066 tmp
= TREE_OPERAND (tmp
, 0);
10068 /* Provide the address of the array. */
10069 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10070 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10072 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10073 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10074 msg
= _("Assignment of scalar to unallocated array");
10075 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10076 &expr1
->where
, msg
);
10080 /* Assignments of scalar derived types with allocatable components
10081 to arrays must be done with a deep copy and the rhs temporary
10082 must have its components deallocated afterwards. */
10083 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10084 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10085 && !gfc_expr_is_variable (expr2
)
10086 && expr1
->rank
&& !expr2
->rank
);
10087 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10089 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10090 && gfc_is_alloc_class_scalar_function (expr2
));
10091 if (scalar_to_array
&& dealloc
)
10093 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10094 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10097 /* When assigning a character function result to a deferred-length variable,
10098 the function call must happen before the (re)allocation of the lhs -
10099 otherwise the character length of the result is not known.
10100 NOTE: This relies on having the exact dependence of the length type
10101 parameter available to the caller; gfortran saves it in the .mod files.
10102 NOTE ALSO: The concatenation operation generates a temporary pointer,
10103 whose allocation must go to the innermost loop.
10104 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10105 if (flag_realloc_lhs
10106 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10107 && !(lss
!= gfc_ss_terminator
10108 && ((expr2
->expr_type
== EXPR_OP
10109 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10110 || (expr2
->expr_type
== EXPR_FUNCTION
10111 && expr2
->value
.function
.isym
!= NULL
10112 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
))))
10113 gfc_add_block_to_block (&block
, &rse
.pre
);
10115 /* Nullify the allocatable components corresponding to those of the lhs
10116 derived type, so that the finalization of the function result does not
10117 affect the lhs of the assignment. Prepend is used to ensure that the
10118 nullification occurs before the call to the finalizer. In the case of
10119 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10120 as part of the deep copy. */
10121 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10122 && (gfc_is_class_array_function (expr2
)
10123 || gfc_is_alloc_class_scalar_function (expr2
)))
10126 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10127 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10128 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10129 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10132 if (is_poly_assign
)
10133 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10134 use_vptr_copy
|| (lhs_attr
.allocatable
10135 && !lhs_attr
.dimension
),
10136 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10137 else if (flag_coarray
== GFC_FCOARRAY_LIB
10138 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10139 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10140 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10142 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10143 allocatable component, because those need to be accessed via the
10144 caf-runtime. No need to check for coindexes here, because resolve
10145 has rewritten those already. */
10147 gfc_actual_arglist a1
, a2
;
10148 /* Clear the structures to prevent accessing garbage. */
10149 memset (&code
, '\0', sizeof (gfc_code
));
10150 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10151 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10156 code
.ext
.actual
= &a1
;
10157 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10158 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10161 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10162 gfc_expr_is_variable (expr2
)
10164 || expr2
->expr_type
== EXPR_ARRAY
,
10165 !(l_is_temp
|| init_flag
) && dealloc
,
10166 expr1
->symtree
->n
.sym
->attr
.codimension
);
10167 /* Add the pre blocks to the body. */
10168 gfc_add_block_to_block (&body
, &rse
.pre
);
10169 gfc_add_block_to_block (&body
, &lse
.pre
);
10170 gfc_add_expr_to_block (&body
, tmp
);
10171 /* Add the post blocks to the body. */
10172 gfc_add_block_to_block (&body
, &rse
.post
);
10173 gfc_add_block_to_block (&body
, &lse
.post
);
10175 if (lss
== gfc_ss_terminator
)
10177 /* F2003: Add the code for reallocation on assignment. */
10178 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10179 && !is_poly_assign
)
10180 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10183 /* Use the scalar assignment as is. */
10184 gfc_add_block_to_block (&block
, &body
);
10188 gcc_assert (lse
.ss
== gfc_ss_terminator
10189 && rse
.ss
== gfc_ss_terminator
);
10193 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10195 /* We need to copy the temporary to the actual lhs. */
10196 gfc_init_se (&lse
, NULL
);
10197 gfc_init_se (&rse
, NULL
);
10198 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10199 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10201 rse
.ss
= loop
.temp_ss
;
10204 gfc_conv_tmp_array_ref (&rse
);
10205 gfc_conv_expr (&lse
, expr1
);
10207 gcc_assert (lse
.ss
== gfc_ss_terminator
10208 && rse
.ss
== gfc_ss_terminator
);
10210 if (expr2
->ts
.type
== BT_CHARACTER
)
10211 rse
.string_length
= string_length
;
10213 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10215 gfc_add_expr_to_block (&body
, tmp
);
10218 /* F2003: Allocate or reallocate lhs of allocatable array. */
10219 if (flag_realloc_lhs
10220 && gfc_is_reallocatable_lhs (expr1
)
10222 && !is_runtime_conformable (expr1
, expr2
))
10224 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10225 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10226 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10227 if (tmp
!= NULL_TREE
)
10228 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10231 if (maybe_workshare
)
10232 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10234 /* Generate the copying loops. */
10235 gfc_trans_scalarizing_loops (&loop
, &body
);
10237 /* Wrap the whole thing up. */
10238 gfc_add_block_to_block (&block
, &loop
.pre
);
10239 gfc_add_block_to_block (&block
, &loop
.post
);
10241 gfc_cleanup_loop (&loop
);
10244 return gfc_finish_block (&block
);
10248 /* Check whether EXPR is a copyable array. */
10251 copyable_array_p (gfc_expr
* expr
)
10253 if (expr
->expr_type
!= EXPR_VARIABLE
)
10256 /* First check it's an array. */
10257 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10260 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10263 /* Next check that it's of a simple enough type. */
10264 switch (expr
->ts
.type
)
10276 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10285 /* Translate an assignment. */
10288 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10289 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10293 /* Special case a single function returning an array. */
10294 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10296 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10301 /* Special case assigning an array to zero. */
10302 if (copyable_array_p (expr1
)
10303 && is_zero_initializer_p (expr2
))
10305 tmp
= gfc_trans_zero_assign (expr1
);
10310 /* Special case copying one array to another. */
10311 if (copyable_array_p (expr1
)
10312 && copyable_array_p (expr2
)
10313 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10314 && !gfc_check_dependency (expr1
, expr2
, 0))
10316 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10321 /* Special case initializing an array from a constant array constructor. */
10322 if (copyable_array_p (expr1
)
10323 && expr2
->expr_type
== EXPR_ARRAY
10324 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10326 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10331 /* Fallback to the scalarizer to generate explicit loops. */
10332 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10333 use_vptr_copy
, may_alias
);
10337 gfc_trans_init_assign (gfc_code
* code
)
10339 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10343 gfc_trans_assign (gfc_code
* code
)
10345 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);