1 /* Expression translation
2 Copyright (C) 2002-2023 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.cc-- 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"
44 #include "tm.h" /* For CHAR_TYPE_SIZE. */
47 /* Calculate the number of characters in a string. */
50 gfc_get_character_len (tree type
)
54 gcc_assert (type
&& TREE_CODE (type
) == ARRAY_TYPE
55 && TYPE_STRING_FLAG (type
));
57 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
58 len
= (len
) ? (len
) : (integer_zero_node
);
59 return fold_convert (gfc_charlen_type_node
, len
);
64 /* Calculate the number of bytes in a string. */
67 gfc_get_character_len_in_bytes (tree type
)
71 gcc_assert (type
&& TREE_CODE (type
) == ARRAY_TYPE
72 && TYPE_STRING_FLAG (type
));
74 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (type
));
75 tmp
= (tmp
&& !integer_zerop (tmp
))
76 ? (fold_convert (gfc_charlen_type_node
, tmp
)) : (NULL_TREE
);
77 len
= gfc_get_character_len (type
);
78 if (tmp
&& len
&& !integer_zerop (len
))
79 len
= fold_build2_loc (input_location
, MULT_EXPR
,
80 gfc_charlen_type_node
, len
, tmp
);
85 /* Convert a scalar to an array descriptor. To be used for assumed-rank
89 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
91 enum gfc_array_kind akind
;
94 akind
= GFC_ARRAY_POINTER_CONT
;
95 else if (attr
.allocatable
)
96 akind
= GFC_ARRAY_ALLOCATABLE
;
98 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
100 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
101 scalar
= TREE_TYPE (scalar
);
102 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
103 akind
, !(attr
.pointer
|| attr
.target
));
107 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
109 tree desc
, type
, etype
;
111 type
= get_scalar_to_descriptor_type (scalar
, attr
);
112 etype
= TREE_TYPE (scalar
);
113 desc
= gfc_create_var (type
, "desc");
114 DECL_ARTIFICIAL (desc
) = 1;
116 if (CONSTANT_CLASS_P (scalar
))
119 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
120 gfc_add_modify (&se
->pre
, tmp
, scalar
);
123 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
124 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
125 else if (TREE_TYPE (etype
) && TREE_CODE (TREE_TYPE (etype
)) == ARRAY_TYPE
)
126 etype
= TREE_TYPE (etype
);
127 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
128 gfc_get_dtype_rank_type (0, etype
));
129 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
130 gfc_conv_descriptor_span_set (&se
->pre
, desc
,
131 gfc_conv_descriptor_elem_len (desc
));
133 /* Copy pointer address back - but only if it could have changed and
134 if the actual argument is a pointer and not, e.g., NULL(). */
135 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
136 gfc_add_modify (&se
->post
, scalar
,
137 fold_convert (TREE_TYPE (scalar
),
138 gfc_conv_descriptor_data_get (desc
)));
143 /* Get the coarray token from the ultimate array or component ref.
144 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
147 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
149 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
150 bool is_coarray
= sym
->attr
.codimension
;
151 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
152 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
156 if (ref
->type
== REF_COMPONENT
157 && (ref
->u
.c
.component
->attr
.allocatable
158 || ref
->u
.c
.component
->attr
.pointer
)
159 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
164 if (last_caf_ref
== NULL
)
167 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
169 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
170 if (comp
== NULL_TREE
&& comp_ref
)
172 gfc_init_se (&se
, outerse
);
173 gfc_free_ref_list (last_caf_ref
->next
);
174 last_caf_ref
->next
= NULL
;
175 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
176 se
.want_pointer
= comp_ref
;
177 gfc_conv_expr (&se
, caf_expr
);
178 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
180 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
181 se
.expr
= TREE_OPERAND (se
.expr
, 0);
182 gfc_free_expr (caf_expr
);
185 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
186 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
188 caf
= gfc_conv_descriptor_token (se
.expr
);
189 return gfc_build_addr_expr (NULL_TREE
, caf
);
193 /* This is the seed for an eventual trans-class.c
195 The following parameters should not be used directly since they might
196 in future implementations. Use the corresponding APIs. */
197 #define CLASS_DATA_FIELD 0
198 #define CLASS_VPTR_FIELD 1
199 #define CLASS_LEN_FIELD 2
200 #define VTABLE_HASH_FIELD 0
201 #define VTABLE_SIZE_FIELD 1
202 #define VTABLE_EXTENDS_FIELD 2
203 #define VTABLE_DEF_INIT_FIELD 3
204 #define VTABLE_COPY_FIELD 4
205 #define VTABLE_FINAL_FIELD 5
206 #define VTABLE_DEALLOCATE_FIELD 6
210 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
214 vec
<constructor_elt
, va_gc
> *init
= NULL
;
216 field
= TYPE_FIELDS (TREE_TYPE (decl
));
217 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
218 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
220 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
221 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
223 return build_constructor (TREE_TYPE (decl
), init
);
228 gfc_class_data_get (tree decl
)
231 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
232 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
233 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
235 return fold_build3_loc (input_location
, COMPONENT_REF
,
236 TREE_TYPE (data
), decl
, data
,
242 gfc_class_vptr_get (tree decl
)
245 /* For class arrays decl may be a temporary descriptor handle, the vptr is
246 then available through the saved descriptor. */
247 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
248 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
249 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
250 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
251 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
252 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
254 return fold_build3_loc (input_location
, COMPONENT_REF
,
255 TREE_TYPE (vptr
), decl
, vptr
,
261 gfc_class_len_get (tree decl
)
264 /* For class arrays decl may be a temporary descriptor handle, the len is
265 then available through the saved descriptor. */
266 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
267 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
268 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
269 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
270 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
271 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
273 return fold_build3_loc (input_location
, COMPONENT_REF
,
274 TREE_TYPE (len
), decl
, len
,
279 /* Try to get the _len component of a class. When the class is not unlimited
280 poly, i.e. no _len field exists, then return a zero node. */
283 gfc_class_len_or_zero_get (tree decl
)
286 /* For class arrays decl may be a temporary descriptor handle, the vptr is
287 then available through the saved descriptor. */
288 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
289 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
290 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
291 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
292 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
293 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
295 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
296 TREE_TYPE (len
), decl
, len
,
298 : build_zero_cst (gfc_charlen_type_node
);
303 gfc_resize_class_size_with_len (stmtblock_t
* block
, tree class_expr
, tree size
)
309 tmp
= gfc_class_len_or_zero_get (class_expr
);
311 /* Include the len value in the element size if present. */
312 if (!integer_zerop (tmp
))
314 type
= TREE_TYPE (size
);
317 size
= gfc_evaluate_now (size
, block
);
318 tmp
= gfc_evaluate_now (fold_convert (type
, tmp
), block
);
320 tmp2
= fold_build2_loc (input_location
, MULT_EXPR
,
322 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
323 logical_type_node
, tmp
,
324 build_zero_cst (type
));
325 size
= fold_build3_loc (input_location
, COND_EXPR
,
326 type
, tmp
, tmp2
, size
);
332 size
= gfc_evaluate_now (size
, block
);
338 /* Get the specified FIELD from the VPTR. */
341 vptr_field_get (tree vptr
, int fieldno
)
344 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
345 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
347 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
348 TREE_TYPE (field
), vptr
, field
,
355 /* Get the field from the class' vptr. */
358 class_vtab_field_get (tree decl
, int fieldno
)
361 vptr
= gfc_class_vptr_get (decl
);
362 return vptr_field_get (vptr
, fieldno
);
366 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
368 #define VTAB_GET_FIELD_GEN(name, field) tree \
369 gfc_class_vtab_## name ##_get (tree cl) \
371 return class_vtab_field_get (cl, field); \
375 gfc_vptr_## name ##_get (tree vptr) \
377 return vptr_field_get (vptr, field); \
380 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
381 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
382 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
383 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
384 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
385 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
386 #undef VTAB_GET_FIELD_GEN
388 /* The size field is returned as an array index type. Therefore treat
389 it and only it specially. */
392 gfc_class_vtab_size_get (tree cl
)
395 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
396 /* Always return size as an array index type. */
397 size
= fold_convert (gfc_array_index_type
, size
);
403 gfc_vptr_size_get (tree vptr
)
406 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
407 /* Always return size as an array index type. */
408 size
= fold_convert (gfc_array_index_type
, size
);
414 #undef CLASS_DATA_FIELD
415 #undef CLASS_VPTR_FIELD
416 #undef CLASS_LEN_FIELD
417 #undef VTABLE_HASH_FIELD
418 #undef VTABLE_SIZE_FIELD
419 #undef VTABLE_EXTENDS_FIELD
420 #undef VTABLE_DEF_INIT_FIELD
421 #undef VTABLE_COPY_FIELD
422 #undef VTABLE_FINAL_FIELD
425 /* IF ts is null (default), search for the last _class ref in the chain
426 of references of the expression and cut the chain there. Although
427 this routine is similiar to class.cc:gfc_add_component_ref (), there
428 is a significant difference: gfc_add_component_ref () concentrates
429 on an array ref that is the last ref in the chain and is oblivious
430 to the kind of refs following.
431 ELSE IF ts is non-null the cut is at the class entity or component
432 that is followed by an array reference, which is not an element.
433 These calls come from trans-array.cc:build_class_array_ref, which
434 handles scalarized class array references.*/
437 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
, bool is_mold
,
441 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
443 /* Find the last class reference. */
450 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
451 *ts
= &e
->symtree
->n
.sym
->ts
;
456 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
460 if (ref
->type
== REF_COMPONENT
461 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
462 && ref
->next
&& ref
->next
->type
== REF_COMPONENT
463 && !strcmp (ref
->next
->u
.c
.component
->name
, "_data")
465 && ref
->next
->next
->type
== REF_ARRAY
466 && ref
->next
->next
->u
.ar
.type
!= AR_ELEMENT
)
468 *ts
= &ref
->u
.c
.component
->ts
;
473 if (ref
->next
== NULL
)
478 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
481 if (ref
->type
== REF_COMPONENT
482 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
484 /* Component to the right of a part reference with nonzero
485 rank must not have the ALLOCATABLE attribute. If attempts
486 are made to reference such a component reference, an error
487 results followed by an ICE. */
489 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
496 if (ts
&& *ts
== NULL
)
499 /* Remove and store all subsequent references after the
503 tail
= class_ref
->next
;
504 class_ref
->next
= NULL
;
506 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
513 base_expr
= gfc_expr_to_initialize (e
);
515 base_expr
= gfc_copy_expr (e
);
517 /* Restore the original tail expression. */
520 gfc_free_ref_list (class_ref
->next
);
521 class_ref
->next
= tail
;
523 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
525 gfc_free_ref_list (e
->ref
);
532 /* Reset the vptr to the declared type, e.g. after deallocation. */
535 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
542 /* Evaluate the expression and obtain the vptr from it. */
543 gfc_init_se (&se
, NULL
);
545 gfc_conv_expr_descriptor (&se
, e
);
547 gfc_conv_expr (&se
, e
);
548 gfc_add_block_to_block (block
, &se
.pre
);
549 vptr
= gfc_get_vptr_from_expr (se
.expr
);
551 /* If a vptr is not found, we can do nothing more. */
552 if (vptr
== NULL_TREE
)
555 if (UNLIMITED_POLY (e
))
556 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
559 /* Return the vptr to the address of the declared type. */
560 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
561 vtable
= vtab
->backend_decl
;
562 if (vtable
== NULL_TREE
)
563 vtable
= gfc_get_symbol_decl (vtab
);
564 vtable
= gfc_build_addr_expr (NULL
, vtable
);
565 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
566 gfc_add_modify (block
, vptr
, vtable
);
571 /* Reset the len for unlimited polymorphic objects. */
574 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
578 e
= gfc_find_and_cut_at_last_class_ref (expr
);
581 gfc_add_len_component (e
);
582 gfc_init_se (&se_len
, NULL
);
583 gfc_conv_expr (&se_len
, e
);
584 gfc_add_modify (block
, se_len
.expr
,
585 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
590 /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
591 reference is found. Note that it is up to the caller to avoid using this
592 for expressions other than variables. */
595 gfc_get_class_from_gfc_expr (gfc_expr
*e
)
597 gfc_expr
*class_expr
;
599 class_expr
= gfc_find_and_cut_at_last_class_ref (e
);
600 if (class_expr
== NULL
)
602 gfc_init_se (&cse
, NULL
);
603 gfc_conv_expr (&cse
, class_expr
);
604 gfc_free_expr (class_expr
);
609 /* Obtain the last class reference in an expression.
610 Return NULL_TREE if no class reference is found. */
613 gfc_get_class_from_expr (tree expr
)
618 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
620 if (CONSTANT_CLASS_P (tmp
))
623 type
= TREE_TYPE (tmp
);
626 if (GFC_CLASS_TYPE_P (type
))
628 if (type
!= TYPE_CANONICAL (type
))
629 type
= TYPE_CANONICAL (type
);
633 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
637 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
638 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
640 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
647 /* Obtain the vptr of the last class reference in an expression.
648 Return NULL_TREE if no class reference is found. */
651 gfc_get_vptr_from_expr (tree expr
)
655 tmp
= gfc_get_class_from_expr (expr
);
657 if (tmp
!= NULL_TREE
)
658 return gfc_class_vptr_get (tmp
);
665 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
668 tree tmp
, tmp2
, type
;
670 gfc_conv_descriptor_data_set (block
, lhs_desc
,
671 gfc_conv_descriptor_data_get (rhs_desc
));
672 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
673 gfc_conv_descriptor_offset_get (rhs_desc
));
675 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
676 gfc_conv_descriptor_dtype (rhs_desc
));
678 /* Assign the dimension as range-ref. */
679 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
680 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
682 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
683 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
684 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
685 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
686 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
687 gfc_add_modify (block
, tmp
, tmp2
);
691 /* Takes a derived type expression and returns the address of a temporary
692 class object of the 'declared' type. If vptr is not NULL, this is
693 used for the temporary class object.
694 optional_alloc_ptr is false when the dummy is neither allocatable
695 nor a pointer; that's only relevant for the optional handling.
696 The optional argument 'derived_array' is used to preserve the parmse
697 expression for deallocation of allocatable components. Assumed rank
698 formal arguments made this necessary. */
700 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
701 gfc_typespec class_ts
, tree vptr
, bool optional
,
702 bool optional_alloc_ptr
,
706 tree cond_optional
= NULL_TREE
;
713 /* The derived type needs to be converted to a temporary
715 tmp
= gfc_typenode_for_spec (&class_ts
);
716 var
= gfc_create_var (tmp
, "class");
719 ctree
= gfc_class_vptr_get (var
);
721 if (vptr
!= NULL_TREE
)
723 /* Use the dynamic vptr. */
728 /* In this case the vtab corresponds to the derived type and the
729 vptr must point to it. */
730 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
732 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
734 gfc_add_modify (&parmse
->pre
, ctree
,
735 fold_convert (TREE_TYPE (ctree
), tmp
));
737 /* Now set the data field. */
738 ctree
= gfc_class_data_get (var
);
741 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
743 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
745 /* If there is a ready made pointer to a derived type, use it
746 rather than evaluating the expression again. */
747 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
748 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
750 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
752 /* For an array reference in an elemental procedure call we need
753 to retain the ss to provide the scalarized array reference. */
754 gfc_conv_expr_reference (parmse
, e
);
755 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
757 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
759 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
760 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
764 ss
= gfc_walk_expr (e
);
765 if (ss
== gfc_ss_terminator
)
768 gfc_conv_expr_reference (parmse
, e
);
770 /* Scalar to an assumed-rank array. */
771 if (class_ts
.u
.derived
->components
->as
)
774 type
= get_scalar_to_descriptor_type (parmse
->expr
,
776 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
777 gfc_get_dtype (type
));
779 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
780 TREE_TYPE (parmse
->expr
),
781 cond_optional
, parmse
->expr
,
782 fold_convert (TREE_TYPE (parmse
->expr
),
784 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
788 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
790 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
792 fold_convert (TREE_TYPE (tmp
),
794 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
800 gfc_init_block (&block
);
804 parmse
->use_offset
= 1;
805 gfc_conv_expr_descriptor (parmse
, e
);
807 /* Detect any array references with vector subscripts. */
808 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
809 if (ref
->type
== REF_ARRAY
810 && ref
->u
.ar
.type
!= AR_ELEMENT
811 && ref
->u
.ar
.type
!= AR_FULL
)
813 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
814 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
816 if (dim
< ref
->u
.ar
.dimen
)
820 /* Array references with vector subscripts and non-variable expressions
821 need be converted to a one-based descriptor. */
822 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
824 for (dim
= 0; dim
< e
->rank
; ++dim
)
825 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
829 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
831 gcc_assert (class_ts
.u
.derived
->components
->as
->type
834 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
->expr
)))
836 *derived_array
= gfc_create_var (TREE_TYPE (parmse
->expr
),
838 gfc_add_modify (&block
, *derived_array
, parmse
->expr
);
840 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
844 if (gfc_expr_attr (e
).codimension
)
845 parmse
->expr
= fold_build1_loc (input_location
,
849 gfc_add_modify (&block
, ctree
, parmse
->expr
);
854 tmp
= gfc_finish_block (&block
);
856 gfc_init_block (&block
);
857 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
858 if (derived_array
&& *derived_array
!= NULL_TREE
)
859 gfc_conv_descriptor_data_set (&block
, *derived_array
,
862 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
863 gfc_finish_block (&block
));
864 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
867 gfc_add_block_to_block (&parmse
->pre
, &block
);
871 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
872 && class_ts
.u
.derived
->components
->ts
.u
.derived
873 ->attr
.unlimited_polymorphic
)
875 /* Take care about initializing the _len component correctly. */
876 ctree
= gfc_class_len_get (var
);
877 if (UNLIMITED_POLY (e
))
882 len
= gfc_find_and_cut_at_last_class_ref (e
);
883 gfc_add_len_component (len
);
884 gfc_init_se (&se
, NULL
);
885 gfc_conv_expr (&se
, len
);
887 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
888 cond_optional
, se
.expr
,
889 fold_convert (TREE_TYPE (se
.expr
),
896 tmp
= integer_zero_node
;
897 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
900 /* Pass the address of the class object. */
901 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
903 if (optional
&& optional_alloc_ptr
)
904 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
905 TREE_TYPE (parmse
->expr
),
906 cond_optional
, parmse
->expr
,
907 fold_convert (TREE_TYPE (parmse
->expr
),
912 /* Create a new class container, which is required as scalar coarrays
913 have an array descriptor while normal scalars haven't. Optionally,
914 NULL pointer checks are added if the argument is OPTIONAL. */
917 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
918 gfc_typespec class_ts
, bool optional
)
920 tree var
, ctree
, tmp
;
925 gfc_init_block (&block
);
928 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
930 if (ref
->type
== REF_COMPONENT
931 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
935 if (class_ref
== NULL
936 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
937 tmp
= e
->symtree
->n
.sym
->backend_decl
;
940 /* Remove everything after the last class reference, convert the
941 expression and then recover its tailend once more. */
943 ref
= class_ref
->next
;
944 class_ref
->next
= NULL
;
945 gfc_init_se (&tmpse
, NULL
);
946 gfc_conv_expr (&tmpse
, e
);
947 class_ref
->next
= ref
;
951 var
= gfc_typenode_for_spec (&class_ts
);
952 var
= gfc_create_var (var
, "class");
954 ctree
= gfc_class_vptr_get (var
);
955 gfc_add_modify (&block
, ctree
,
956 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
958 ctree
= gfc_class_data_get (var
);
959 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
960 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
962 /* Pass the address of the class object. */
963 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
967 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
970 tmp
= gfc_finish_block (&block
);
972 gfc_init_block (&block
);
973 tmp2
= gfc_class_data_get (var
);
974 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
976 tmp2
= gfc_finish_block (&block
);
978 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
980 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
983 gfc_add_block_to_block (&parmse
->pre
, &block
);
987 /* Takes an intrinsic type expression and returns the address of a temporary
988 class object of the 'declared' type. */
990 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
991 gfc_typespec class_ts
)
1000 /* The intrinsic type needs to be converted to a temporary
1002 tmp
= gfc_typenode_for_spec (&class_ts
);
1003 var
= gfc_create_var (tmp
, "class");
1006 ctree
= gfc_class_vptr_get (var
);
1008 vtab
= gfc_find_vtab (&e
->ts
);
1010 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
1011 gfc_add_modify (&parmse
->pre
, ctree
,
1012 fold_convert (TREE_TYPE (ctree
), tmp
));
1014 /* Now set the data field. */
1015 ctree
= gfc_class_data_get (var
);
1016 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
1018 /* For an array reference in an elemental procedure call we need
1019 to retain the ss to provide the scalarized array reference. */
1020 gfc_conv_expr_reference (parmse
, e
);
1021 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
1022 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
1026 ss
= gfc_walk_expr (e
);
1027 if (ss
== gfc_ss_terminator
)
1030 gfc_conv_expr_reference (parmse
, e
);
1031 if (class_ts
.u
.derived
->components
->as
1032 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
1034 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
1036 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1037 TREE_TYPE (ctree
), tmp
);
1040 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
1041 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
1046 parmse
->use_offset
= 1;
1047 gfc_conv_expr_descriptor (parmse
, e
);
1049 /* Array references with vector subscripts and non-variable expressions
1050 need be converted to a one-based descriptor. */
1051 if (e
->expr_type
!= EXPR_VARIABLE
)
1053 for (dim
= 0; dim
< e
->rank
; ++dim
)
1054 gfc_conv_shift_descriptor_lbound (&parmse
->pre
, parmse
->expr
,
1055 dim
, gfc_index_one_node
);
1058 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
1060 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1061 TREE_TYPE (ctree
), parmse
->expr
);
1062 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
1065 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
1069 gcc_assert (class_ts
.type
== BT_CLASS
);
1070 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
1071 && class_ts
.u
.derived
->components
->ts
.u
.derived
1072 ->attr
.unlimited_polymorphic
)
1074 ctree
= gfc_class_len_get (var
);
1075 /* When the actual arg is a char array, then set the _len component of the
1076 unlimited polymorphic entity to the length of the string. */
1077 if (e
->ts
.type
== BT_CHARACTER
)
1079 /* Start with parmse->string_length because this seems to be set to a
1080 correct value more often. */
1081 if (parmse
->string_length
)
1082 tmp
= parmse
->string_length
;
1083 /* When the string_length is not yet set, then try the backend_decl of
1085 else if (e
->ts
.u
.cl
->backend_decl
)
1086 tmp
= e
->ts
.u
.cl
->backend_decl
;
1087 /* If both of the above approaches fail, then try to generate an
1088 expression from the input, which is only feasible currently, when the
1089 expression can be evaluated to a constant one. */
1092 /* Try to simplify the expression. */
1093 gfc_simplify_expr (e
, 0);
1094 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
1096 /* Amazingly all data is present to compute the length of a
1097 constant string, but the expression is not yet there. */
1098 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
1099 gfc_charlen_int_kind
,
1101 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
1102 e
->value
.character
.length
);
1103 gfc_conv_const_charlen (e
->ts
.u
.cl
);
1104 e
->ts
.u
.cl
->resolved
= 1;
1105 tmp
= e
->ts
.u
.cl
->backend_decl
;
1109 gfc_error ("Cannot compute the length of the char array "
1110 "at %L.", &e
->where
);
1115 tmp
= integer_zero_node
;
1117 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
1119 else if (class_ts
.type
== BT_CLASS
1120 && class_ts
.u
.derived
->components
1121 && class_ts
.u
.derived
->components
->ts
.u
1122 .derived
->attr
.unlimited_polymorphic
)
1124 ctree
= gfc_class_len_get (var
);
1125 gfc_add_modify (&parmse
->pre
, ctree
,
1126 fold_convert (TREE_TYPE (ctree
),
1127 integer_zero_node
));
1129 /* Pass the address of the class object. */
1130 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1134 /* Takes a scalarized class array expression and returns the
1135 address of a temporary scalar class object of the 'declared'
1137 OOP-TODO: This could be improved by adding code that branched on
1138 the dynamic type being the same as the declared type. In this case
1139 the original class expression can be passed directly.
1140 optional_alloc_ptr is false when the dummy is neither allocatable
1141 nor a pointer; that's relevant for the optional handling.
1142 Set copyback to true if class container's _data and _vtab pointers
1143 might get modified. */
1146 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
1147 bool elemental
, bool copyback
, bool optional
,
1148 bool optional_alloc_ptr
)
1154 tree cond
= NULL_TREE
;
1155 tree slen
= NULL_TREE
;
1159 bool full_array
= false;
1161 gfc_init_block (&block
);
1164 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1166 if (ref
->type
== REF_COMPONENT
1167 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
1170 if (ref
->next
== NULL
)
1174 if ((ref
== NULL
|| class_ref
== ref
)
1175 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
1176 && (!class_ts
.u
.derived
->components
->as
1177 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
1180 /* Test for FULL_ARRAY. */
1182 && ((gfc_expr_attr (e
).codimension
&& gfc_expr_attr (e
).dimension
)
1183 || (class_ts
.u
.derived
->components
->as
1184 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)))
1187 gfc_is_class_array_ref (e
, &full_array
);
1189 /* The derived type needs to be converted to a temporary
1191 tmp
= gfc_typenode_for_spec (&class_ts
);
1192 var
= gfc_create_var (tmp
, "class");
1195 ctree
= gfc_class_data_get (var
);
1196 if (class_ts
.u
.derived
->components
->as
1197 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1201 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1203 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1204 gfc_get_dtype (type
));
1206 tmp
= gfc_class_data_get (parmse
->expr
);
1207 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1208 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1210 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1213 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1217 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1218 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1219 TREE_TYPE (ctree
), parmse
->expr
);
1220 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1223 /* Return the data component, except in the case of scalarized array
1224 references, where nullification of the cannot occur and so there
1226 if (!elemental
&& full_array
&& copyback
)
1228 if (class_ts
.u
.derived
->components
->as
1229 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1233 tmp
= gfc_class_data_get (parmse
->expr
);
1234 gfc_add_modify (&parmse
->post
, tmp
,
1235 fold_convert (TREE_TYPE (tmp
),
1236 gfc_conv_descriptor_data_get (ctree
)));
1239 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1242 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1246 ctree
= gfc_class_vptr_get (var
);
1248 /* The vptr is the second field of the actual argument.
1249 First we have to find the corresponding class reference. */
1252 if (gfc_is_class_array_function (e
)
1253 && parmse
->class_vptr
!= NULL_TREE
)
1254 tmp
= parmse
->class_vptr
;
1255 else if (class_ref
== NULL
1256 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1258 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1260 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1261 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1263 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1264 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1266 slen
= build_zero_cst (size_type_node
);
1270 /* Remove everything after the last class reference, convert the
1271 expression and then recover its tailend once more. */
1273 ref
= class_ref
->next
;
1274 class_ref
->next
= NULL
;
1275 gfc_init_se (&tmpse
, NULL
);
1276 gfc_conv_expr (&tmpse
, e
);
1277 class_ref
->next
= ref
;
1279 slen
= tmpse
.string_length
;
1282 gcc_assert (tmp
!= NULL_TREE
);
1284 /* Dereference if needs be. */
1285 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1286 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1288 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1289 vptr
= gfc_class_vptr_get (tmp
);
1293 gfc_add_modify (&block
, ctree
,
1294 fold_convert (TREE_TYPE (ctree
), vptr
));
1296 /* Return the vptr component, except in the case of scalarized array
1297 references, where the dynamic type cannot change. */
1298 if (!elemental
&& full_array
&& copyback
)
1299 gfc_add_modify (&parmse
->post
, vptr
,
1300 fold_convert (TREE_TYPE (vptr
), ctree
));
1302 /* For unlimited polymorphic objects also set the _len component. */
1303 if (class_ts
.type
== BT_CLASS
1304 && class_ts
.u
.derived
->components
1305 && class_ts
.u
.derived
->components
->ts
.u
1306 .derived
->attr
.unlimited_polymorphic
)
1308 ctree
= gfc_class_len_get (var
);
1309 if (UNLIMITED_POLY (e
))
1310 tmp
= gfc_class_len_get (tmp
);
1311 else if (e
->ts
.type
== BT_CHARACTER
)
1313 gcc_assert (slen
!= NULL_TREE
);
1317 tmp
= build_zero_cst (size_type_node
);
1318 gfc_add_modify (&parmse
->pre
, ctree
,
1319 fold_convert (TREE_TYPE (ctree
), tmp
));
1321 /* Return the len component, except in the case of scalarized array
1322 references, where the dynamic type cannot change. */
1323 if (!elemental
&& full_array
&& copyback
1324 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1325 gfc_add_modify (&parmse
->post
, tmp
,
1326 fold_convert (TREE_TYPE (tmp
), ctree
));
1333 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1334 /* parmse->pre may contain some preparatory instructions for the
1335 temporary array descriptor. Those may only be executed when the
1336 optional argument is set, therefore add parmse->pre's instructions
1337 to block, which is later guarded by an if (optional_arg_given). */
1338 gfc_add_block_to_block (&parmse
->pre
, &block
);
1339 block
.head
= parmse
->pre
.head
;
1340 parmse
->pre
.head
= NULL_TREE
;
1341 tmp
= gfc_finish_block (&block
);
1343 if (optional_alloc_ptr
)
1344 tmp2
= build_empty_stmt (input_location
);
1347 gfc_init_block (&block
);
1349 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1350 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1351 null_pointer_node
));
1352 tmp2
= gfc_finish_block (&block
);
1355 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1357 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1360 gfc_add_block_to_block (&parmse
->pre
, &block
);
1362 /* Pass the address of the class object. */
1363 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1365 if (optional
&& optional_alloc_ptr
)
1366 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1367 TREE_TYPE (parmse
->expr
),
1369 fold_convert (TREE_TYPE (parmse
->expr
),
1370 null_pointer_node
));
1374 /* Given a class array declaration and an index, returns the address
1375 of the referenced element. */
1378 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1381 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1383 data
= data_comp
!= NULL_TREE
? data_comp
:
1384 gfc_class_data_get (class_decl
);
1385 size
= gfc_class_vtab_size_get (class_decl
);
1389 tmp
= fold_convert (gfc_array_index_type
,
1390 gfc_class_len_get (class_decl
));
1391 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1392 gfc_array_index_type
, size
, tmp
);
1393 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1394 logical_type_node
, tmp
,
1395 build_zero_cst (TREE_TYPE (tmp
)));
1396 size
= fold_build3_loc (input_location
, COND_EXPR
,
1397 gfc_array_index_type
, tmp
, ctmp
, size
);
1400 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1401 gfc_array_index_type
,
1404 data
= gfc_conv_descriptor_data_get (data
);
1405 ptr
= fold_convert (pvoid_type_node
, data
);
1406 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1407 return fold_convert (TREE_TYPE (data
), ptr
);
1411 /* Copies one class expression to another, assuming that if either
1412 'to' or 'from' are arrays they are packed. Should 'from' be
1413 NULL_TREE, the initialization expression for 'to' is used, assuming
1414 that the _vptr is set. */
1417 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1427 vec
<tree
, va_gc
> *args
;
1432 bool is_from_desc
= false, is_to_class
= false;
1435 /* To prevent warnings on uninitialized variables. */
1436 from_len
= to_len
= NULL_TREE
;
1438 if (from
!= NULL_TREE
)
1439 fcn
= gfc_class_vtab_copy_get (from
);
1441 fcn
= gfc_class_vtab_copy_get (to
);
1443 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1445 if (from
!= NULL_TREE
)
1447 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1451 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1455 /* Check that from is a class. When the class is part of a coarray,
1456 then from is a common pointer and is to be used as is. */
1457 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1458 ? build_fold_indirect_ref (from
) : from
;
1460 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1461 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1462 ? gfc_class_data_get (from
) : from
;
1463 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1467 from_data
= gfc_class_vtab_def_init_get (to
);
1471 if (from
!= NULL_TREE
&& unlimited
)
1472 from_len
= gfc_class_len_or_zero_get (from
);
1474 from_len
= build_zero_cst (size_type_node
);
1477 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1480 to_data
= gfc_class_data_get (to
);
1482 to_len
= gfc_class_len_get (to
);
1485 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1488 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1490 stmtblock_t loopbody
;
1494 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1496 gfc_init_block (&body
);
1497 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1498 gfc_array_index_type
, nelems
,
1499 gfc_index_one_node
);
1500 nelems
= gfc_evaluate_now (tmp
, &body
);
1501 index
= gfc_create_var (gfc_array_index_type
, "S");
1505 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1507 vec_safe_push (args
, from_ref
);
1510 vec_safe_push (args
, from_data
);
1513 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1516 tmp
= gfc_conv_array_data (to
);
1517 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1518 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1519 gfc_build_array_ref (tmp
, index
, to
));
1521 vec_safe_push (args
, to_ref
);
1523 /* Add bounds check. */
1524 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1527 const char *name
= "<<unknown>>";
1531 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1533 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1534 from_len
= fold_convert (TREE_TYPE (orig_nelems
), from_len
);
1535 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1536 logical_type_node
, from_len
, orig_nelems
);
1537 msg
= xasprintf ("Array bound mismatch for dimension %d "
1538 "of array '%s' (%%ld/%%ld)",
1541 gfc_trans_runtime_check (true, false, tmp
, &body
,
1542 &gfc_current_locus
, msg
,
1543 fold_convert (long_integer_type_node
, orig_nelems
),
1544 fold_convert (long_integer_type_node
, from_len
));
1549 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1551 /* Build the body of the loop. */
1552 gfc_init_block (&loopbody
);
1553 gfc_add_expr_to_block (&loopbody
, tmp
);
1555 /* Build the loop and return. */
1556 gfc_init_loopinfo (&loop
);
1558 loop
.from
[0] = gfc_index_zero_node
;
1559 loop
.loopvar
[0] = index
;
1560 loop
.to
[0] = nelems
;
1561 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1562 gfc_init_block (&ifbody
);
1563 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1564 stdcopy
= gfc_finish_block (&ifbody
);
1565 /* In initialization mode from_len is a constant zero. */
1566 if (unlimited
&& !integer_zerop (from_len
))
1568 vec_safe_push (args
, from_len
);
1569 vec_safe_push (args
, to_len
);
1570 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1571 /* Build the body of the loop. */
1572 gfc_init_block (&loopbody
);
1573 gfc_add_expr_to_block (&loopbody
, tmp
);
1575 /* Build the loop and return. */
1576 gfc_init_loopinfo (&loop
);
1578 loop
.from
[0] = gfc_index_zero_node
;
1579 loop
.loopvar
[0] = index
;
1580 loop
.to
[0] = nelems
;
1581 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1582 gfc_init_block (&ifbody
);
1583 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1584 extcopy
= gfc_finish_block (&ifbody
);
1586 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1587 logical_type_node
, from_len
,
1588 build_zero_cst (TREE_TYPE (from_len
)));
1589 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1590 void_type_node
, tmp
, extcopy
, stdcopy
);
1591 gfc_add_expr_to_block (&body
, tmp
);
1592 tmp
= gfc_finish_block (&body
);
1596 gfc_add_expr_to_block (&body
, stdcopy
);
1597 tmp
= gfc_finish_block (&body
);
1599 gfc_cleanup_loop (&loop
);
1603 gcc_assert (!is_from_desc
);
1604 vec_safe_push (args
, from_data
);
1605 vec_safe_push (args
, to_data
);
1606 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1608 /* In initialization mode from_len is a constant zero. */
1609 if (unlimited
&& !integer_zerop (from_len
))
1611 vec_safe_push (args
, from_len
);
1612 vec_safe_push (args
, to_len
);
1613 extcopy
= build_call_vec (fcn_type
, unshare_expr (fcn
), args
);
1614 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1615 logical_type_node
, from_len
,
1616 build_zero_cst (TREE_TYPE (from_len
)));
1617 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1618 void_type_node
, tmp
, extcopy
, stdcopy
);
1624 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1625 if (from
== NULL_TREE
)
1628 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1630 from_data
, null_pointer_node
);
1631 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1632 void_type_node
, cond
,
1633 tmp
, build_empty_stmt (input_location
));
1641 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1643 gfc_actual_arglist
*actual
;
1648 actual
= gfc_get_actual_arglist ();
1649 actual
->expr
= gfc_copy_expr (rhs
);
1650 actual
->next
= gfc_get_actual_arglist ();
1651 actual
->next
->expr
= gfc_copy_expr (lhs
);
1652 ppc
= gfc_copy_expr (obj
);
1653 gfc_add_vptr_component (ppc
);
1654 gfc_add_component_ref (ppc
, "_copy");
1655 ppc_code
= gfc_get_code (EXEC_CALL
);
1656 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1657 /* Although '_copy' is set to be elemental in class.cc, it is
1658 not staying that way. Find out why, sometime.... */
1659 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1660 ppc_code
->ext
.actual
= actual
;
1661 ppc_code
->expr1
= ppc
;
1662 /* Since '_copy' is elemental, the scalarizer will take care
1663 of arrays in gfc_trans_call. */
1664 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1665 gfc_free_statements (ppc_code
);
1667 if (UNLIMITED_POLY(obj
))
1669 /* Check if rhs is non-NULL. */
1671 gfc_init_se (&src
, NULL
);
1672 gfc_conv_expr (&src
, rhs
);
1673 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1674 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1675 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1676 null_pointer_node
));
1677 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1678 build_empty_stmt (input_location
));
1684 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1685 A MEMCPY is needed to copy the full data from the default initializer
1686 of the dynamic type. */
1689 gfc_trans_class_init_assign (gfc_code
*code
)
1693 gfc_se dst
,src
,memsz
;
1694 gfc_expr
*lhs
, *rhs
, *sz
;
1696 gfc_start_block (&block
);
1698 lhs
= gfc_copy_expr (code
->expr1
);
1700 rhs
= gfc_copy_expr (code
->expr1
);
1701 gfc_add_vptr_component (rhs
);
1703 /* Make sure that the component backend_decls have been built, which
1704 will not have happened if the derived types concerned have not
1706 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1707 gfc_add_def_init_component (rhs
);
1708 /* The _def_init is always scalar. */
1711 if (code
->expr1
->ts
.type
== BT_CLASS
1712 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1714 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1715 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1716 /* Adding the array ref to the class expression results in correct
1717 indexing to the dynamic type. */
1718 gfc_add_full_array_ref (lhs
, tmparr
);
1719 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1723 /* Scalar initialization needs the _data component. */
1724 gfc_add_data_component (lhs
);
1725 sz
= gfc_copy_expr (code
->expr1
);
1726 gfc_add_vptr_component (sz
);
1727 gfc_add_size_component (sz
);
1729 gfc_init_se (&dst
, NULL
);
1730 gfc_init_se (&src
, NULL
);
1731 gfc_init_se (&memsz
, NULL
);
1732 gfc_conv_expr (&dst
, lhs
);
1733 gfc_conv_expr (&src
, rhs
);
1734 gfc_conv_expr (&memsz
, sz
);
1735 gfc_add_block_to_block (&block
, &src
.pre
);
1736 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1738 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1740 if (UNLIMITED_POLY(code
->expr1
))
1742 /* Check if _def_init is non-NULL. */
1743 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1744 logical_type_node
, src
.expr
,
1745 fold_convert (TREE_TYPE (src
.expr
),
1746 null_pointer_node
));
1747 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1748 tmp
, build_empty_stmt (input_location
));
1752 if (code
->expr1
->symtree
->n
.sym
->attr
.dummy
1753 && (code
->expr1
->symtree
->n
.sym
->attr
.optional
1754 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
))
1756 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1757 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1759 build_empty_stmt (input_location
));
1762 gfc_add_expr_to_block (&block
, tmp
);
1764 return gfc_finish_block (&block
);
1768 /* Class valued elemental function calls or class array elements arriving
1769 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1770 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1773 trans_scalar_class_assign (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
)
1782 stmtblock_t inner_block
;
1784 bool not_call_expr
= TREE_CODE (rse
->expr
) != CALL_EXPR
;
1785 bool not_lhs_array_type
;
1787 /* Temporaries arising from dependencies in assignment get cast as a
1788 character type of the dynamic size of the rhs. Use the vptr copy
1790 tmp
= TREE_TYPE (lse
->expr
);
1791 not_lhs_array_type
= !(tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
1792 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) != NULL_TREE
);
1794 /* Use ordinary assignment if the rhs is not a call expression or
1795 the lhs is not a class entity or an array(ie. character) type. */
1796 if ((not_call_expr
&& gfc_get_class_from_expr (lse
->expr
) == NULL_TREE
)
1797 && not_lhs_array_type
)
1800 /* Ordinary assignment can be used if both sides are class expressions
1801 since the dynamic type is preserved by copying the vptr. This
1802 should only occur, where temporaries are involved. */
1803 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
1804 && GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
1807 /* Fix the class expression and the class data of the rhs. */
1808 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
1811 tmp
= gfc_get_class_from_expr (rse
->expr
);
1812 if (tmp
== NULL_TREE
)
1814 rse_expr
= gfc_evaluate_now (tmp
, block
);
1817 rse_expr
= gfc_evaluate_now (rse
->expr
, block
);
1819 class_data
= gfc_class_data_get (rse_expr
);
1821 /* Check that the rhs data is not null. */
1822 is_descriptor
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data
));
1824 class_data
= gfc_conv_descriptor_data_get (class_data
);
1825 class_data
= gfc_evaluate_now (class_data
, block
);
1827 zero
= build_int_cst (TREE_TYPE (class_data
), 0);
1828 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1832 /* Copy the rhs to the lhs. */
1833 fcn
= gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr
));
1834 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1835 tmp
= gfc_evaluate_now (gfc_build_addr_expr (NULL
, rse
->expr
), block
);
1836 tmp
= is_descriptor
? tmp
: class_data
;
1837 tmp
= build_call_expr_loc (input_location
, fcn
, 2, tmp
,
1838 gfc_build_addr_expr (NULL
, lse
->expr
));
1839 gfc_add_expr_to_block (block
, tmp
);
1841 /* Only elemental function results need to be finalised and freed. */
1845 /* Finalize the class data if needed. */
1846 gfc_init_block (&inner_block
);
1847 fcn
= gfc_vptr_final_get (gfc_class_vptr_get (rse_expr
));
1848 zero
= build_int_cst (TREE_TYPE (fcn
), 0);
1849 final_cond
= fold_build2_loc (input_location
, NE_EXPR
,
1850 logical_type_node
, fcn
, zero
);
1851 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1852 tmp
= build_call_expr_loc (input_location
, fcn
, 1, class_data
);
1853 tmp
= build3_v (COND_EXPR
, final_cond
,
1854 tmp
, build_empty_stmt (input_location
));
1855 gfc_add_expr_to_block (&inner_block
, tmp
);
1857 /* Free the class data. */
1858 tmp
= gfc_call_free (class_data
);
1859 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1860 build_empty_stmt (input_location
));
1861 gfc_add_expr_to_block (&inner_block
, tmp
);
1863 /* Finish the inner block and subject it to the condition on the
1864 class data being non-zero. */
1865 tmp
= gfc_finish_block (&inner_block
);
1866 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1867 build_empty_stmt (input_location
));
1868 gfc_add_expr_to_block (block
, tmp
);
1873 /* End of prototype trans-class.c */
1877 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1879 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1880 gfc_warning (OPT_Wrealloc_lhs
,
1881 "Code for reallocating the allocatable array at %L will "
1883 else if (warn_realloc_lhs_all
)
1884 gfc_warning (OPT_Wrealloc_lhs_all
,
1885 "Code for reallocating the allocatable variable at %L "
1886 "will be added", where
);
1890 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1893 /* Copy the scalarization loop variables. */
1896 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1899 dest
->loop
= src
->loop
;
1903 /* Initialize a simple expression holder.
1905 Care must be taken when multiple se are created with the same parent.
1906 The child se must be kept in sync. The easiest way is to delay creation
1907 of a child se until after the previous se has been translated. */
1910 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1912 memset (se
, 0, sizeof (gfc_se
));
1913 gfc_init_block (&se
->pre
);
1914 gfc_init_block (&se
->finalblock
);
1915 gfc_init_block (&se
->post
);
1917 se
->parent
= parent
;
1920 gfc_copy_se_loopvars (se
, parent
);
1924 /* Advances to the next SS in the chain. Use this rather than setting
1925 se->ss = se->ss->next because all the parents needs to be kept in sync.
1929 gfc_advance_se_ss_chain (gfc_se
* se
)
1934 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1937 /* Walk down the parent chain. */
1940 /* Simple consistency check. */
1941 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1942 || p
->parent
->ss
->nested_ss
== p
->ss
);
1944 /* If we were in a nested loop, the next scalarized expression can be
1945 on the parent ss' next pointer. Thus we should not take the next
1946 pointer blindly, but rather go up one nest level as long as next
1947 is the end of chain. */
1949 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1959 /* Ensures the result of the expression as either a temporary variable
1960 or a constant so that it can be used repeatedly. */
1963 gfc_make_safe_expr (gfc_se
* se
)
1967 if (CONSTANT_CLASS_P (se
->expr
))
1970 /* We need a temporary for this result. */
1971 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1972 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1977 /* Return an expression which determines if a dummy parameter is present.
1978 Also used for arguments to procedures with multiple entry points. */
1981 gfc_conv_expr_present (gfc_symbol
* sym
, bool use_saved_desc
)
1983 tree decl
, orig_decl
, cond
;
1985 gcc_assert (sym
->attr
.dummy
);
1986 orig_decl
= decl
= gfc_get_symbol_decl (sym
);
1988 /* Intrinsic scalars with VALUE attribute which are passed by value
1989 use a hidden argument to denote the present status. */
1990 if (sym
->attr
.value
&& !sym
->attr
.dimension
1991 && sym
->ts
.type
!= BT_CLASS
&& !gfc_bt_struct (sym
->ts
.type
))
1993 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1996 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1998 strcpy (&name
[1], sym
->name
);
1999 tree_name
= get_identifier (name
);
2001 /* Walk function argument list to find hidden arg. */
2002 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
2003 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
2004 if (DECL_NAME (cond
) == tree_name
2005 && DECL_ARTIFICIAL (cond
))
2012 /* Assumed-shape arrays use a local variable for the array data;
2013 the actual PARAM_DECL is in a saved decl. As the local variable
2014 is NULL, it can be checked instead, unless use_saved_desc is
2017 if (use_saved_desc
&& TREE_CODE (decl
) != PARM_DECL
)
2019 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
2020 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
2021 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
2024 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
2025 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
2027 /* Fortran 2008 allows to pass null pointers and non-associated pointers
2028 as actual argument to denote absent dummies. For array descriptors,
2029 we thus also need to check the array descriptor. For BT_CLASS, it
2030 can also occur for scalars and F2003 due to type->class wrapping and
2031 class->class wrapping. Note further that BT_CLASS always uses an
2032 array descriptor for arrays, also for explicit-shape/assumed-size.
2033 For assumed-rank arrays, no local variable is generated, hence,
2034 the following also applies with !use_saved_desc. */
2036 if ((use_saved_desc
|| TREE_CODE (orig_decl
) == PARM_DECL
)
2037 && !sym
->attr
.allocatable
2038 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
2039 || (sym
->ts
.type
== BT_CLASS
2040 && !CLASS_DATA (sym
)->attr
.allocatable
2041 && !CLASS_DATA (sym
)->attr
.class_pointer
))
2042 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
2043 || sym
->ts
.type
== BT_CLASS
))
2047 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
2048 || sym
->as
->type
== AS_ASSUMED_RANK
2049 || sym
->attr
.codimension
))
2050 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
2052 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
2053 if (sym
->ts
.type
== BT_CLASS
)
2054 tmp
= gfc_class_data_get (tmp
);
2055 tmp
= gfc_conv_array_data (tmp
);
2057 else if (sym
->ts
.type
== BT_CLASS
)
2058 tmp
= gfc_class_data_get (decl
);
2062 if (tmp
!= NULL_TREE
)
2064 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
2065 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2066 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2067 logical_type_node
, cond
, tmp
);
2075 /* Converts a missing, dummy argument into a null or zero. */
2078 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
2083 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2087 /* Create a temporary and convert it to the correct type. */
2088 tmp
= gfc_get_int_type (kind
);
2089 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
2092 /* Test for a NULL value. */
2093 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
2094 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
2095 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2096 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2100 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
2102 build_zero_cst (TREE_TYPE (se
->expr
)));
2103 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2107 if (ts
.type
== BT_CHARACTER
)
2109 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2110 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
2111 present
, se
->string_length
, tmp
);
2112 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2113 se
->string_length
= tmp
;
2119 /* Get the character length of an expression, looking through gfc_refs
2123 gfc_get_expr_charlen (gfc_expr
*e
)
2129 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2130 && e
->ts
.type
== BT_CHARACTER
);
2132 length
= NULL
; /* To silence compiler warning. */
2134 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
2137 gfc_init_se (&tmpse
, NULL
);
2138 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
2139 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
2143 /* First candidate: if the variable is of type CHARACTER, the
2144 expression's length could be the length of the character
2146 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2147 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2149 /* Look through the reference chain for component references. */
2150 for (r
= e
->ref
; r
; r
= r
->next
)
2155 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
2156 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
2164 gfc_init_se (&se
, NULL
);
2165 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
2167 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
2168 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
2169 gfc_charlen_type_node
,
2171 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
2172 gfc_charlen_type_node
, length
,
2173 gfc_index_one_node
);
2182 gcc_assert (length
!= NULL
);
2187 /* Return for an expression the backend decl of the coarray. */
2190 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
2196 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
2198 /* Not-implemented diagnostic. */
2199 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
2200 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
2201 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2202 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2203 "%L is not supported", &expr
->where
);
2205 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2206 if (ref
->type
== REF_COMPONENT
)
2208 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
2209 && UNLIMITED_POLY (ref
->u
.c
.component
)
2210 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
2211 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2212 "component at %L is not supported", &expr
->where
);
2215 /* Make sure the backend_decl is present before accessing it. */
2216 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
2217 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
2218 : expr
->symtree
->n
.sym
->backend_decl
;
2220 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2222 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
2224 caf_decl
= gfc_class_data_get (caf_decl
);
2225 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2228 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2230 if (ref
->type
== REF_COMPONENT
2231 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
2233 caf_decl
= gfc_class_data_get (caf_decl
);
2234 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2238 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
2242 if (expr
->symtree
->n
.sym
->attr
.codimension
)
2245 /* The following code assumes that the coarray is a component reachable via
2246 only scalar components/variables; the Fortran standard guarantees this. */
2248 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2249 if (ref
->type
== REF_COMPONENT
)
2251 gfc_component
*comp
= ref
->u
.c
.component
;
2253 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
2254 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2255 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2256 TREE_TYPE (comp
->backend_decl
), caf_decl
,
2257 comp
->backend_decl
, NULL_TREE
);
2258 if (comp
->ts
.type
== BT_CLASS
)
2260 caf_decl
= gfc_class_data_get (caf_decl
);
2261 if (CLASS_DATA (comp
)->attr
.codimension
)
2267 if (comp
->attr
.codimension
)
2273 gcc_assert (found
&& caf_decl
);
2278 /* Obtain the Coarray token - and optionally also the offset. */
2281 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2282 tree se_expr
, gfc_expr
*expr
)
2286 /* Coarray token. */
2287 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2289 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2290 == GFC_ARRAY_ALLOCATABLE
2291 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2292 *token
= gfc_conv_descriptor_token (caf_decl
);
2294 else if (DECL_LANG_SPECIFIC (caf_decl
)
2295 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2296 *token
= GFC_DECL_TOKEN (caf_decl
);
2299 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2300 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2301 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2307 /* Offset between the coarray base address and the address wanted. */
2308 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2309 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2310 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2311 *offset
= build_int_cst (gfc_array_index_type
, 0);
2312 else if (DECL_LANG_SPECIFIC (caf_decl
)
2313 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2314 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2315 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2316 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2318 *offset
= build_int_cst (gfc_array_index_type
, 0);
2320 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2321 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2323 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2324 tmp
= gfc_conv_descriptor_data_get (tmp
);
2326 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2327 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2330 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2334 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2335 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2337 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2338 && expr
->symtree
->n
.sym
->attr
.codimension
2339 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2341 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2342 gfc_ref
*ref
= base_expr
->ref
;
2345 // Iterate through the refs until the last one.
2349 if (ref
->type
== REF_ARRAY
2350 && ref
->u
.ar
.type
!= AR_FULL
)
2352 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2354 for (i
= 0; i
< ranksum
; ++i
)
2356 ref
->u
.ar
.start
[i
] = NULL
;
2357 ref
->u
.ar
.end
[i
] = NULL
;
2359 ref
->u
.ar
.type
= AR_FULL
;
2361 gfc_init_se (&base_se
, NULL
);
2362 if (gfc_caf_attr (base_expr
).dimension
)
2364 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2365 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2369 gfc_conv_expr (&base_se
, base_expr
);
2373 gfc_free_expr (base_expr
);
2374 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2375 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2377 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2378 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2381 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2385 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2386 fold_convert (gfc_array_index_type
, *offset
),
2387 fold_convert (gfc_array_index_type
, tmp
));
2391 /* Convert the coindex of a coarray into an image index; the result is
2392 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2393 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2396 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2399 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2403 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2404 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2406 gcc_assert (ref
!= NULL
);
2408 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2410 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2414 img_idx
= build_zero_cst (gfc_array_index_type
);
2415 extent
= build_one_cst (gfc_array_index_type
);
2416 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2417 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2419 gfc_init_se (&se
, NULL
);
2420 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2421 gfc_add_block_to_block (block
, &se
.pre
);
2422 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2423 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2424 TREE_TYPE (lbound
), se
.expr
, lbound
);
2425 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2427 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2428 TREE_TYPE (tmp
), img_idx
, tmp
);
2429 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2431 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2432 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2433 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2434 TREE_TYPE (tmp
), extent
, tmp
);
2438 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2440 gfc_init_se (&se
, NULL
);
2441 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2442 gfc_add_block_to_block (block
, &se
.pre
);
2443 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2444 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2445 TREE_TYPE (lbound
), se
.expr
, lbound
);
2446 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2448 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2450 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2452 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2453 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2454 TREE_TYPE (ubound
), ubound
, lbound
);
2455 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2456 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2457 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2458 TREE_TYPE (tmp
), extent
, tmp
);
2461 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2462 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2463 return fold_convert (integer_type_node
, img_idx
);
2467 /* For each character array constructor subexpression without a ts.u.cl->length,
2468 replace it by its first element (if there aren't any elements, the length
2469 should already be set to zero). */
2472 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2474 gfc_actual_arglist
* arg
;
2480 switch (e
->expr_type
)
2484 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2485 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2489 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2493 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2494 flatten_array_ctors_without_strlen (arg
->expr
);
2499 /* We've found what we're looking for. */
2500 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2505 gcc_assert (e
->value
.constructor
);
2507 c
= gfc_constructor_first (e
->value
.constructor
);
2511 flatten_array_ctors_without_strlen (new_expr
);
2512 gfc_replace_expr (e
, new_expr
);
2516 /* Otherwise, fall through to handle constructor elements. */
2518 case EXPR_STRUCTURE
:
2519 for (c
= gfc_constructor_first (e
->value
.constructor
);
2520 c
; c
= gfc_constructor_next (c
))
2521 flatten_array_ctors_without_strlen (c
->expr
);
2531 /* Generate code to initialize a string length variable. Returns the
2532 value. For array constructors, cl->length might be NULL and in this case,
2533 the first element of the constructor is needed. expr is the original
2534 expression so we can access it but can be NULL if this is not needed. */
2537 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2541 gfc_init_se (&se
, NULL
);
2543 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2546 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2547 "flatten" array constructors by taking their first element; all elements
2548 should be the same length or a cl->length should be present. */
2551 gfc_expr
* expr_flat
;
2554 expr_flat
= gfc_copy_expr (expr
);
2555 flatten_array_ctors_without_strlen (expr_flat
);
2556 gfc_resolve_expr (expr_flat
);
2558 gfc_conv_expr (&se
, expr_flat
);
2559 gfc_add_block_to_block (pblock
, &se
.pre
);
2560 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2562 gfc_free_expr (expr_flat
);
2566 /* Convert cl->length. */
2568 gcc_assert (cl
->length
);
2570 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2571 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2572 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2573 gfc_add_block_to_block (pblock
, &se
.pre
);
2575 if (cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2576 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2578 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2583 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2584 const char *name
, locus
*where
)
2594 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2595 type
= build_pointer_type (type
);
2597 gfc_init_se (&start
, se
);
2598 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2599 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2601 if (integer_onep (start
.expr
))
2602 gfc_conv_string_parameter (se
);
2607 /* Avoid multiple evaluation of substring start. */
2608 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2609 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2611 /* Change the start of the string. */
2612 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2613 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2614 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2617 tmp
= build_fold_indirect_ref_loc (input_location
,
2619 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2620 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
2622 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL_TREE
, true);
2623 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2627 /* Length = end + 1 - start. */
2628 gfc_init_se (&end
, se
);
2629 if (ref
->u
.ss
.end
== NULL
)
2630 end
.expr
= se
->string_length
;
2633 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2634 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2638 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2639 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2641 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2642 && (ref
->u
.ss
.start
->symtree
2643 && !ref
->u
.ss
.start
->symtree
->n
.sym
->attr
.implied_index
))
2645 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2646 logical_type_node
, start
.expr
,
2649 /* Check lower bound. */
2650 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2652 build_one_cst (TREE_TYPE (start
.expr
)));
2653 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2654 logical_type_node
, nonempty
, fault
);
2656 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2657 "is less than one", name
);
2659 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2660 "is less than one");
2661 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2662 fold_convert (long_integer_type_node
,
2666 /* Check upper bound. */
2667 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2668 end
.expr
, se
->string_length
);
2669 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2670 logical_type_node
, nonempty
, fault
);
2672 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2673 "exceeds string length (%%ld)", name
);
2675 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2676 "exceeds string length (%%ld)");
2677 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2678 fold_convert (long_integer_type_node
, end
.expr
),
2679 fold_convert (long_integer_type_node
,
2680 se
->string_length
));
2684 /* Try to calculate the length from the start and end expressions. */
2686 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2688 HOST_WIDE_INT i_len
;
2690 i_len
= gfc_mpz_get_hwi (length
) + 1;
2694 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2695 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2699 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2700 fold_convert (gfc_charlen_type_node
, end
.expr
),
2701 fold_convert (gfc_charlen_type_node
, start
.expr
));
2702 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2703 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2704 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2705 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2708 se
->string_length
= tmp
;
2712 /* Convert a derived type component reference. */
2715 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2723 c
= ref
->u
.c
.component
;
2725 if (c
->backend_decl
== NULL_TREE
2726 && ref
->u
.c
.sym
!= NULL
)
2727 gfc_get_derived_type (ref
->u
.c
.sym
);
2729 field
= c
->backend_decl
;
2730 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2732 context
= DECL_FIELD_CONTEXT (field
);
2734 /* Components can correspond to fields of different containing
2735 types, as components are created without context, whereas
2736 a concrete use of a component has the type of decl as context.
2737 So, if the type doesn't match, we search the corresponding
2738 FIELD_DECL in the parent type. To not waste too much time
2739 we cache this result in norestrict_decl.
2740 On the other hand, if the context is a UNION or a MAP (a
2741 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2743 if (context
!= TREE_TYPE (decl
)
2744 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2745 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2747 tree f2
= c
->norestrict_decl
;
2748 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2749 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2750 if (TREE_CODE (f2
) == FIELD_DECL
2751 && DECL_NAME (f2
) == DECL_NAME (field
))
2754 c
->norestrict_decl
= f2
;
2758 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2759 && strcmp ("_data", c
->name
) == 0)
2761 /* Found a ref to the _data component. Store the associated ref to
2762 the vptr in se->class_vptr. */
2763 se
->class_vptr
= gfc_class_vptr_get (decl
);
2766 se
->class_vptr
= NULL_TREE
;
2768 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2769 decl
, field
, NULL_TREE
);
2773 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2774 strlen () conditional below. */
2775 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2777 && !c
->attr
.pdt_string
)
2779 tmp
= c
->ts
.u
.cl
->backend_decl
;
2780 /* Components must always be constant length. */
2781 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2782 se
->string_length
= tmp
;
2785 if (gfc_deferred_strlen (c
, &field
))
2787 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2789 decl
, field
, NULL_TREE
);
2790 se
->string_length
= tmp
;
2793 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2794 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2795 && c
->ts
.type
!= BT_CHARACTER
)
2796 || c
->attr
.proc_pointer
)
2797 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2802 /* This function deals with component references to components of the
2803 parent type for derived type extensions. */
2805 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2813 c
= ref
->u
.c
.component
;
2815 /* Return if the component is in this type, i.e. not in the parent type. */
2816 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2820 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2821 parent
.type
= REF_COMPONENT
;
2823 parent
.u
.c
.sym
= dt
;
2824 parent
.u
.c
.component
= dt
->components
;
2826 if (dt
->backend_decl
== NULL
)
2827 gfc_get_derived_type (dt
);
2829 /* Build the reference and call self. */
2830 gfc_conv_component_ref (se
, &parent
);
2831 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2832 parent
.u
.c
.component
= c
;
2833 conv_parent_component_references (se
, &parent
);
2838 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2840 tree res
= se
->expr
;
2845 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2846 TREE_TYPE (TREE_TYPE (res
)), res
);
2850 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2851 TREE_TYPE (TREE_TYPE (res
)), res
);
2855 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2860 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2870 /* Dereference VAR where needed if it is a pointer, reference, etc.
2871 according to Fortran semantics. */
2874 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2877 if (!POINTER_TYPE_P (TREE_TYPE (var
)))
2879 if (is_CFI_desc (sym
, NULL
))
2880 return build_fold_indirect_ref_loc (input_location
, var
);
2882 /* Characters are entirely different from other types, they are treated
2884 if (sym
->ts
.type
== BT_CHARACTER
)
2886 /* Dereference character pointer dummy arguments
2888 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2889 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2891 || sym
->attr
.function
2892 || sym
->attr
.result
))
2893 var
= build_fold_indirect_ref_loc (input_location
, var
);
2895 else if (!sym
->attr
.value
)
2897 /* Dereference temporaries for class array dummy arguments. */
2898 if (sym
->attr
.dummy
&& is_classarray
2899 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2901 if (!descriptor_only_p
)
2902 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2904 var
= build_fold_indirect_ref_loc (input_location
, var
);
2907 /* Dereference non-character scalar dummy arguments. */
2908 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2909 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2910 && (sym
->ts
.type
!= BT_CLASS
2911 || (!CLASS_DATA (sym
)->attr
.dimension
2912 && !(CLASS_DATA (sym
)->attr
.codimension
2913 && CLASS_DATA (sym
)->attr
.allocatable
))))
2914 var
= build_fold_indirect_ref_loc (input_location
, var
);
2916 /* Dereference scalar hidden result. */
2917 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2918 && (sym
->attr
.function
|| sym
->attr
.result
)
2919 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2920 && !sym
->attr
.always_explicit
)
2921 var
= build_fold_indirect_ref_loc (input_location
, var
);
2923 /* Dereference non-character, non-class pointer variables.
2924 These must be dummies, results, or scalars. */
2926 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2927 || gfc_is_associate_pointer (sym
)
2928 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2930 || sym
->attr
.function
2932 || (!sym
->attr
.dimension
2933 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2934 var
= build_fold_indirect_ref_loc (input_location
, var
);
2935 /* Now treat the class array pointer variables accordingly. */
2936 else if (sym
->ts
.type
== BT_CLASS
2938 && (CLASS_DATA (sym
)->attr
.dimension
2939 || CLASS_DATA (sym
)->attr
.codimension
)
2940 && ((CLASS_DATA (sym
)->as
2941 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2942 || CLASS_DATA (sym
)->attr
.allocatable
2943 || CLASS_DATA (sym
)->attr
.class_pointer
))
2944 var
= build_fold_indirect_ref_loc (input_location
, var
);
2945 /* And the case where a non-dummy, non-result, non-function,
2946 non-allocable and non-pointer classarray is present. This case was
2947 previously covered by the first if, but with introducing the
2948 condition !is_classarray there, that case has to be covered
2950 else if (sym
->ts
.type
== BT_CLASS
2952 && !sym
->attr
.function
2953 && !sym
->attr
.result
2954 && (CLASS_DATA (sym
)->attr
.dimension
2955 || CLASS_DATA (sym
)->attr
.codimension
)
2957 || !CLASS_DATA (sym
)->attr
.allocatable
)
2958 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2959 var
= build_fold_indirect_ref_loc (input_location
, var
);
2965 /* Return the contents of a variable. Also handles reference/pointer
2966 variables (all Fortran pointer references are implicit). */
2969 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2974 tree parent_decl
= NULL_TREE
;
2977 bool alternate_entry
;
2980 bool first_time
= true;
2982 sym
= expr
->symtree
->n
.sym
;
2983 is_classarray
= IS_CLASS_ARRAY (sym
);
2987 gfc_ss_info
*ss_info
= ss
->info
;
2989 /* Check that something hasn't gone horribly wrong. */
2990 gcc_assert (ss
!= gfc_ss_terminator
);
2991 gcc_assert (ss_info
->expr
== expr
);
2993 /* A scalarized term. We already know the descriptor. */
2994 se
->expr
= ss_info
->data
.array
.descriptor
;
2995 se
->string_length
= ss_info
->string_length
;
2996 ref
= ss_info
->data
.array
.ref
;
2998 gcc_assert (ref
->type
== REF_ARRAY
2999 && ref
->u
.ar
.type
!= AR_ELEMENT
);
3001 gfc_conv_tmp_array_ref (se
);
3005 tree se_expr
= NULL_TREE
;
3007 se
->expr
= gfc_get_symbol_decl (sym
);
3009 /* Deal with references to a parent results or entries by storing
3010 the current_function_decl and moving to the parent_decl. */
3011 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
3012 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
3013 && sym
->result
== sym
;
3014 entry_master
= sym
->attr
.result
3015 && sym
->ns
->proc_name
->attr
.entry_master
3016 && !gfc_return_by_reference (sym
->ns
->proc_name
);
3017 if (current_function_decl
)
3018 parent_decl
= DECL_CONTEXT (current_function_decl
);
3020 if ((se
->expr
== parent_decl
&& return_value
)
3021 || (sym
->ns
&& sym
->ns
->proc_name
3023 && sym
->ns
->proc_name
->backend_decl
== parent_decl
3024 && (alternate_entry
|| entry_master
)))
3029 /* Special case for assigning the return value of a function.
3030 Self recursive functions must have an explicit return value. */
3031 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
3032 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3034 /* Similarly for alternate entry points. */
3035 else if (alternate_entry
3036 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
3039 gfc_entry_list
*el
= NULL
;
3041 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3044 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3049 else if (entry_master
3050 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
3052 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3057 /* Procedure actual arguments. Look out for temporary variables
3058 with the same attributes as function values. */
3059 else if (!sym
->attr
.temporary
3060 && sym
->attr
.flavor
== FL_PROCEDURE
3061 && se
->expr
!= current_function_decl
)
3063 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
3065 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
3066 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3071 /* Dereference the expression, where needed. */
3072 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
3078 /* For character variables, also get the length. */
3079 if (sym
->ts
.type
== BT_CHARACTER
)
3081 /* If the character length of an entry isn't set, get the length from
3082 the master function instead. */
3083 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
3084 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
3086 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3087 gcc_assert (se
->string_length
);
3090 gfc_typespec
*ts
= &sym
->ts
;
3096 /* Return the descriptor if that's what we want and this is an array
3097 section reference. */
3098 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
3100 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3101 /* Return the descriptor for array pointers and allocations. */
3102 if (se
->want_pointer
3103 && ref
->next
== NULL
&& (se
->descriptor_only
))
3106 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
3107 /* Return a pointer to an element. */
3111 ts
= &ref
->u
.c
.component
->ts
;
3112 if (first_time
&& is_classarray
&& sym
->attr
.dummy
3113 && se
->descriptor_only
3114 && !CLASS_DATA (sym
)->attr
.allocatable
3115 && !CLASS_DATA (sym
)->attr
.class_pointer
3116 && CLASS_DATA (sym
)->as
3117 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
3118 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
3119 /* Skip the first ref of a _data component, because for class
3120 arrays that one is already done by introducing a temporary
3121 array descriptor. */
3124 if (ref
->u
.c
.sym
->attr
.extension
)
3125 conv_parent_component_references (se
, ref
);
3127 gfc_conv_component_ref (se
, ref
);
3128 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
3129 && se
->want_pointer
&& se
->descriptor_only
)
3135 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
3136 expr
->symtree
->name
, &expr
->where
);
3140 conv_inquiry (se
, ref
, expr
, ts
);
3150 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3152 if (se
->want_pointer
)
3154 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
3155 gfc_conv_string_parameter (se
);
3157 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3162 /* Unary ops are easy... Or they would be if ! was a valid op. */
3165 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
3170 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3171 /* Initialize the operand. */
3172 gfc_init_se (&operand
, se
);
3173 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
3174 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
3176 type
= gfc_typenode_for_spec (&expr
->ts
);
3178 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3179 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3180 All other unary operators have an equivalent GIMPLE unary operator. */
3181 if (code
== TRUTH_NOT_EXPR
)
3182 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
3183 build_int_cst (type
, 0));
3185 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
3189 /* Expand power operator to optimal multiplications when a value is raised
3190 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3191 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3192 Programming", 3rd Edition, 1998. */
3194 /* This code is mostly duplicated from expand_powi in the backend.
3195 We establish the "optimal power tree" lookup table with the defined size.
3196 The items in the table are the exponents used to calculate the index
3197 exponents. Any integer n less than the value can get an "addition chain",
3198 with the first node being one. */
3199 #define POWI_TABLE_SIZE 256
3201 /* The table is from builtins.cc. */
3202 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
3204 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3205 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3206 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3207 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3208 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3209 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3210 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3211 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3212 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3213 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3214 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3215 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3216 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3217 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3218 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3219 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3220 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3221 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3222 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3223 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3224 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3225 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3226 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3227 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3228 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3229 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3230 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3231 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3232 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3233 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3234 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3235 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3238 /* If n is larger than lookup table's max index, we use the "window
3240 #define POWI_WINDOW_SIZE 3
3242 /* Recursive function to expand the power operator. The temporary
3243 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3245 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
3252 if (n
< POWI_TABLE_SIZE
)
3257 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
3258 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
3262 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
3263 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
3264 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
3268 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
3272 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
3273 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3275 if (n
< POWI_TABLE_SIZE
)
3282 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3283 return 1. Else return 0 and a call to runtime library functions
3284 will have to be built. */
3286 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3291 tree vartmp
[POWI_TABLE_SIZE
];
3293 unsigned HOST_WIDE_INT n
;
3295 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3297 /* If exponent is too large, we won't expand it anyway, so don't bother
3298 with large integer values. */
3299 if (!wi::fits_shwi_p (wrhs
))
3302 m
= wrhs
.to_shwi ();
3303 /* Use the wide_int's routine to reliably get the absolute value on all
3304 platforms. Then convert it to a HOST_WIDE_INT like above. */
3305 n
= wi::abs (wrhs
).to_shwi ();
3307 type
= TREE_TYPE (lhs
);
3308 sgn
= tree_int_cst_sgn (rhs
);
3310 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3311 || optimize_size
) && (m
> 2 || m
< -1))
3317 se
->expr
= gfc_build_const (type
, integer_one_node
);
3321 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3322 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3324 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3325 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3326 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3327 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3330 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3333 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3334 logical_type_node
, tmp
, cond
);
3335 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3336 tmp
, build_int_cst (type
, 1),
3337 build_int_cst (type
, 0));
3341 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3342 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3343 build_int_cst (type
, -1),
3344 build_int_cst (type
, 0));
3345 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3346 cond
, build_int_cst (type
, 1), tmp
);
3350 memset (vartmp
, 0, sizeof (vartmp
));
3354 tmp
= gfc_build_const (type
, integer_one_node
);
3355 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3359 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3365 /* Power op (**). Constant integer exponent has special handling. */
3368 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3370 tree gfc_int4_type_node
;
3373 int res_ikind_1
, res_ikind_2
;
3378 gfc_init_se (&lse
, se
);
3379 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3380 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3381 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3383 gfc_init_se (&rse
, se
);
3384 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3385 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3387 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3388 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3389 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3392 if (INTEGER_CST_P (lse
.expr
)
3393 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3395 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3397 int kind
, ikind
, bit_size
;
3399 v
= wlhs
.to_shwi ();
3402 kind
= expr
->value
.op
.op1
->ts
.kind
;
3403 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3404 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3408 /* 1**something is always 1. */
3409 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3414 /* (-1)**n is 1 - ((n & 1) << 1) */
3418 type
= TREE_TYPE (lse
.expr
);
3419 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3420 rse
.expr
, build_int_cst (type
, 1));
3421 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3422 tmp
, build_int_cst (type
, 1));
3423 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3424 build_int_cst (type
, 1), tmp
);
3428 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3430 /* Here v is +/- 2**e. The further simplification uses
3431 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3432 1<<(4*n), etc., but we have to make sure to return zero
3433 if the number of bits is too large. */
3443 type
= TREE_TYPE (lse
.expr
);
3448 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3449 TREE_TYPE (rse
.expr
),
3450 rse
.expr
, rse
.expr
);
3453 /* use popcount for fast log2(w) */
3454 int e
= wi::popcount (w
-1);
3455 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3456 TREE_TYPE (rse
.expr
),
3457 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3461 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3462 build_int_cst (type
, 1), shift
);
3463 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3464 rse
.expr
, build_int_cst (type
, 0));
3465 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3466 build_int_cst (type
, 0));
3467 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3468 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3469 rse
.expr
, num_bits
);
3470 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3471 build_int_cst (type
, 0), cond
);
3478 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3480 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3481 rse
.expr
, build_int_cst (type
, 1));
3482 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3483 tmp2
, build_int_cst (type
, 1));
3484 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3485 build_int_cst (type
, 1), tmp2
);
3486 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3493 gfc_int4_type_node
= gfc_get_int_type (4);
3495 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3496 library routine. But in the end, we have to convert the result back
3497 if this case applies -- with res_ikind_K, we keep track whether operand K
3498 falls into this case. */
3502 kind
= expr
->value
.op
.op1
->ts
.kind
;
3503 switch (expr
->value
.op
.op2
->ts
.type
)
3506 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3511 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3512 res_ikind_2
= ikind
;
3534 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3536 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3563 switch (expr
->value
.op
.op1
->ts
.type
)
3566 if (kind
== 3) /* Case 16 was not handled properly above. */
3568 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3572 /* Use builtins for real ** int4. */
3578 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3582 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3586 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3590 /* Use the __builtin_powil() only if real(kind=16) is
3591 actually the C long double type. */
3592 if (!gfc_real16_is_float128
)
3593 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3601 /* If we don't have a good builtin for this, go for the
3602 library function. */
3604 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3608 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3617 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3621 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3629 se
->expr
= build_call_expr_loc (input_location
,
3630 fndecl
, 2, lse
.expr
, rse
.expr
);
3632 /* Convert the result back if it is of wrong integer kind. */
3633 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3635 /* We want the maximum of both operand kinds as result. */
3636 if (res_ikind_1
< res_ikind_2
)
3637 res_ikind_1
= res_ikind_2
;
3638 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3643 /* Generate code to allocate a string temporary. */
3646 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3651 if (gfc_can_put_var_on_stack (len
))
3653 /* Create a temporary variable to hold the result. */
3654 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3655 TREE_TYPE (len
), len
,
3656 build_int_cst (TREE_TYPE (len
), 1));
3657 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3659 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3660 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3662 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3664 var
= gfc_create_var (tmp
, "str");
3665 var
= gfc_build_addr_expr (type
, var
);
3669 /* Allocate a temporary to hold the result. */
3670 var
= gfc_create_var (type
, "pstr");
3671 gcc_assert (POINTER_TYPE_P (type
));
3672 tmp
= TREE_TYPE (type
);
3673 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3674 tmp
= TREE_TYPE (tmp
);
3675 tmp
= TYPE_SIZE_UNIT (tmp
);
3676 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3677 fold_convert (size_type_node
, len
),
3678 fold_convert (size_type_node
, tmp
));
3679 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3680 gfc_add_modify (&se
->pre
, var
, tmp
);
3682 /* Free the temporary afterwards. */
3683 tmp
= gfc_call_free (var
);
3684 gfc_add_expr_to_block (&se
->post
, tmp
);
3691 /* Handle a string concatenation operation. A temporary will be allocated to
3695 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3698 tree len
, type
, var
, tmp
, fndecl
;
3700 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3701 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3702 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3704 gfc_init_se (&lse
, se
);
3705 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3706 gfc_conv_string_parameter (&lse
);
3707 gfc_init_se (&rse
, se
);
3708 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3709 gfc_conv_string_parameter (&rse
);
3711 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3712 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3714 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3715 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3716 if (len
== NULL_TREE
)
3718 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3719 gfc_charlen_type_node
,
3720 fold_convert (gfc_charlen_type_node
,
3722 fold_convert (gfc_charlen_type_node
,
3723 rse
.string_length
));
3726 type
= build_pointer_type (type
);
3728 var
= gfc_conv_string_tmp (se
, type
, len
);
3730 /* Do the actual concatenation. */
3731 if (expr
->ts
.kind
== 1)
3732 fndecl
= gfor_fndecl_concat_string
;
3733 else if (expr
->ts
.kind
== 4)
3734 fndecl
= gfor_fndecl_concat_string_char4
;
3738 tmp
= build_call_expr_loc (input_location
,
3739 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3740 rse
.string_length
, rse
.expr
);
3741 gfc_add_expr_to_block (&se
->pre
, tmp
);
3743 /* Add the cleanup for the operands. */
3744 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3745 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3748 se
->string_length
= len
;
3751 /* Translates an op expression. Common (binary) cases are handled by this
3752 function, others are passed on. Recursion is used in either case.
3753 We use the fact that (op1.ts == op2.ts) (except for the power
3755 Operators need no special handling for scalarized expressions as long as
3756 they call gfc_conv_simple_val to get their operands.
3757 Character strings get special handling. */
3760 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3762 enum tree_code code
;
3771 switch (expr
->value
.op
.op
)
3773 case INTRINSIC_PARENTHESES
:
3774 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3775 && flag_protect_parens
)
3777 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3778 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3783 case INTRINSIC_UPLUS
:
3784 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3787 case INTRINSIC_UMINUS
:
3788 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3792 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3795 case INTRINSIC_PLUS
:
3799 case INTRINSIC_MINUS
:
3803 case INTRINSIC_TIMES
:
3807 case INTRINSIC_DIVIDE
:
3808 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3809 an integer, we must round towards zero, so we use a
3811 if (expr
->ts
.type
== BT_INTEGER
)
3812 code
= TRUNC_DIV_EXPR
;
3817 case INTRINSIC_POWER
:
3818 gfc_conv_power_op (se
, expr
);
3821 case INTRINSIC_CONCAT
:
3822 gfc_conv_concat_op (se
, expr
);
3826 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3831 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3835 /* EQV and NEQV only work on logicals, but since we represent them
3836 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3838 case INTRINSIC_EQ_OS
:
3846 case INTRINSIC_NE_OS
:
3847 case INTRINSIC_NEQV
:
3854 case INTRINSIC_GT_OS
:
3861 case INTRINSIC_GE_OS
:
3868 case INTRINSIC_LT_OS
:
3875 case INTRINSIC_LE_OS
:
3881 case INTRINSIC_USER
:
3882 case INTRINSIC_ASSIGN
:
3883 /* These should be converted into function calls by the frontend. */
3887 fatal_error (input_location
, "Unknown intrinsic op");
3891 /* The only exception to this is **, which is handled separately anyway. */
3892 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3894 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3898 gfc_init_se (&lse
, se
);
3899 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3900 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3903 gfc_init_se (&rse
, se
);
3904 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3905 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3909 gfc_conv_string_parameter (&lse
);
3910 gfc_conv_string_parameter (&rse
);
3912 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3913 rse
.string_length
, rse
.expr
,
3914 expr
->value
.op
.op1
->ts
.kind
,
3916 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3917 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3920 type
= gfc_typenode_for_spec (&expr
->ts
);
3924 /* The result of logical ops is always logical_type_node. */
3925 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3926 lse
.expr
, rse
.expr
);
3927 se
->expr
= convert (type
, tmp
);
3930 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3932 /* Add the post blocks. */
3933 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3934 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3937 /* If a string's length is one, we convert it to a single character. */
3940 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3944 || !tree_fits_uhwi_p (len
)
3945 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3948 if (TREE_INT_CST_LOW (len
) == 1)
3950 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3951 return build_fold_indirect_ref_loc (input_location
, str
);
3955 && TREE_CODE (str
) == ADDR_EXPR
3956 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3957 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3958 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3959 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3960 && TREE_INT_CST_LOW (len
) > 1
3961 && TREE_INT_CST_LOW (len
)
3962 == (unsigned HOST_WIDE_INT
)
3963 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3965 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3966 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3967 if (TREE_CODE (ret
) == INTEGER_CST
)
3969 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3970 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3971 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3973 for (i
= 1; i
< length
; i
++)
3986 conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3990 /* We used to modify the tree here. Now it is done earlier in
3991 the front-end, so we only check it here to avoid regressions. */
3992 if (sym
->backend_decl
)
3994 gcc_assert (TREE_CODE (TREE_TYPE (sym
->backend_decl
)) == INTEGER_TYPE
);
3995 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym
->backend_decl
)) == 1);
3996 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym
->backend_decl
)) == CHAR_TYPE_SIZE
);
3997 gcc_assert (DECL_BY_REFERENCE (sym
->backend_decl
) == 0);
4000 /* If we have a constant character expression, make it into an
4001 integer of type C char. */
4002 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
4007 *expr
= gfc_get_int_expr (gfc_default_character_kind
, NULL
,
4008 (*expr
)->value
.character
.string
[0]);
4010 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
4012 if ((*expr
)->ref
== NULL
)
4014 se
->expr
= gfc_string_to_single_character
4015 (build_int_cst (integer_type_node
, 1),
4016 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
4018 ((*expr
)->symtree
->n
.sym
)),
4023 gfc_conv_variable (se
, *expr
);
4024 se
->expr
= gfc_string_to_single_character
4025 (build_int_cst (integer_type_node
, 1),
4026 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
4033 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4034 if STR is a string literal, otherwise return -1. */
4037 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
4040 && TREE_CODE (str
) == ADDR_EXPR
4041 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
4042 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
4043 && array_ref_low_bound (TREE_OPERAND (str
, 0))
4044 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
4045 && tree_fits_uhwi_p (len
)
4046 && tree_to_uhwi (len
) >= 1
4047 && tree_to_uhwi (len
)
4048 == (unsigned HOST_WIDE_INT
)
4049 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
4051 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
4052 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
4053 if (TREE_CODE (folded
) == INTEGER_CST
)
4055 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
4056 int length
= TREE_STRING_LENGTH (string_cst
);
4057 const char *ptr
= TREE_STRING_POINTER (string_cst
);
4059 for (; length
> 0; length
--)
4060 if (ptr
[length
- 1] != ' ')
4069 /* Helper to build a call to memcmp. */
4072 build_memcmp_call (tree s1
, tree s2
, tree n
)
4076 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
4077 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
4079 s1
= fold_convert (pvoid_type_node
, s1
);
4081 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
4082 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
4084 s2
= fold_convert (pvoid_type_node
, s2
);
4086 n
= fold_convert (size_type_node
, n
);
4088 tmp
= build_call_expr_loc (input_location
,
4089 builtin_decl_explicit (BUILT_IN_MEMCMP
),
4092 return fold_convert (integer_type_node
, tmp
);
4095 /* Compare two strings. If they are all single characters, the result is the
4096 subtraction of them. Otherwise, we build a library call. */
4099 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
4100 enum tree_code code
)
4106 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
4107 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
4109 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
4110 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
4112 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
4114 /* Deal with single character specially. */
4115 sc1
= fold_convert (integer_type_node
, sc1
);
4116 sc2
= fold_convert (integer_type_node
, sc2
);
4117 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4121 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
4123 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
4125 /* If one string is a string literal with LEN_TRIM longer
4126 than the length of the second string, the strings
4128 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
4129 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
4130 return integer_one_node
;
4131 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
4132 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
4133 return integer_one_node
;
4136 /* We can compare via memcpy if the strings are known to be equal
4137 in length and they are
4139 - kind=4 and the comparison is for (in)equality. */
4141 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
4142 && tree_int_cst_equal (len1
, len2
)
4143 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
4148 chartype
= gfc_get_char_type (kind
);
4149 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
4150 fold_convert (TREE_TYPE(len1
),
4151 TYPE_SIZE_UNIT(chartype
)),
4153 return build_memcmp_call (str1
, str2
, tmp
);
4156 /* Build a call for the comparison. */
4158 fndecl
= gfor_fndecl_compare_string
;
4160 fndecl
= gfor_fndecl_compare_string_char4
;
4164 return build_call_expr_loc (input_location
, fndecl
, 4,
4165 len1
, str1
, len2
, str2
);
4169 /* Return the backend_decl for a procedure pointer component. */
4172 get_proc_ptr_comp (gfc_expr
*e
)
4178 gfc_init_se (&comp_se
, NULL
);
4179 e2
= gfc_copy_expr (e
);
4180 /* We have to restore the expr type later so that gfc_free_expr frees
4181 the exact same thing that was allocated.
4182 TODO: This is ugly. */
4183 old_type
= e2
->expr_type
;
4184 e2
->expr_type
= EXPR_VARIABLE
;
4185 gfc_conv_expr (&comp_se
, e2
);
4186 e2
->expr_type
= old_type
;
4188 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
4192 /* Convert a typebound function reference from a class object. */
4194 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
4199 if (!VAR_P (base_object
))
4201 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
4202 gfc_add_modify (&se
->pre
, var
, base_object
);
4204 se
->expr
= gfc_class_vptr_get (base_object
);
4205 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4207 while (ref
&& ref
->next
)
4209 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
4210 if (ref
->u
.c
.sym
->attr
.extension
)
4211 conv_parent_component_references (se
, ref
);
4212 gfc_conv_component_ref (se
, ref
);
4213 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
4218 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
4219 gfc_actual_arglist
*actual_args
)
4223 if (gfc_is_proc_ptr_comp (expr
))
4224 tmp
= get_proc_ptr_comp (expr
);
4225 else if (sym
->attr
.dummy
)
4227 tmp
= gfc_get_symbol_decl (sym
);
4228 if (sym
->attr
.proc_pointer
)
4229 tmp
= build_fold_indirect_ref_loc (input_location
,
4231 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
4232 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
4236 if (!sym
->backend_decl
)
4237 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
4239 TREE_USED (sym
->backend_decl
) = 1;
4241 tmp
= sym
->backend_decl
;
4243 if (sym
->attr
.cray_pointee
)
4245 /* TODO - make the cray pointee a pointer to a procedure,
4246 assign the pointer to it and use it for the call. This
4248 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
4249 gfc_get_symbol_decl (sym
->cp_pointer
));
4250 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4253 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
4255 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
4256 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4263 /* Initialize MAPPING. */
4266 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
4268 mapping
->syms
= NULL
;
4269 mapping
->charlens
= NULL
;
4273 /* Free all memory held by MAPPING (but not MAPPING itself). */
4276 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4278 gfc_interface_sym_mapping
*sym
;
4279 gfc_interface_sym_mapping
*nextsym
;
4281 gfc_charlen
*nextcl
;
4283 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4285 nextsym
= sym
->next
;
4286 sym
->new_sym
->n
.sym
->formal
= NULL
;
4287 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4288 gfc_free_expr (sym
->expr
);
4289 free (sym
->new_sym
);
4292 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4295 gfc_free_expr (cl
->length
);
4301 /* Return a copy of gfc_charlen CL. Add the returned structure to
4302 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4304 static gfc_charlen
*
4305 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4308 gfc_charlen
*new_charlen
;
4310 new_charlen
= gfc_get_charlen ();
4311 new_charlen
->next
= mapping
->charlens
;
4312 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4314 mapping
->charlens
= new_charlen
;
4319 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4320 array variable that can be used as the actual argument for dummy
4321 argument SYM. Add any initialization code to BLOCK. PACKED is as
4322 for gfc_get_nodesc_array_type and DATA points to the first element
4323 in the passed array. */
4326 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4327 gfc_packed packed
, tree data
)
4332 type
= gfc_typenode_for_spec (&sym
->ts
);
4333 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4334 !sym
->attr
.target
&& !sym
->attr
.pointer
4335 && !sym
->attr
.proc_pointer
);
4337 var
= gfc_create_var (type
, "ifm");
4338 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4344 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4345 and offset of descriptorless array type TYPE given that it has the same
4346 size as DESC. Add any set-up code to BLOCK. */
4349 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4356 offset
= gfc_index_zero_node
;
4357 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4359 dim
= gfc_rank_cst
[n
];
4360 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4361 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4363 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4364 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4365 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4366 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4368 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4370 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4371 gfc_array_index_type
,
4372 gfc_conv_descriptor_ubound_get (desc
, dim
),
4373 gfc_conv_descriptor_lbound_get (desc
, dim
));
4374 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4375 gfc_array_index_type
,
4376 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4377 tmp
= gfc_evaluate_now (tmp
, block
);
4378 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4380 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4381 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4382 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4383 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4384 gfc_array_index_type
, offset
, tmp
);
4386 offset
= gfc_evaluate_now (offset
, block
);
4387 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4391 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4392 in SE. The caller may still use se->expr and se->string_length after
4393 calling this function. */
4396 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4397 gfc_symbol
* sym
, gfc_se
* se
,
4400 gfc_interface_sym_mapping
*sm
;
4404 gfc_symbol
*new_sym
;
4406 gfc_symtree
*new_symtree
;
4408 /* Create a new symbol to represent the actual argument. */
4409 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4410 new_sym
->ts
= sym
->ts
;
4411 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4412 new_sym
->attr
.referenced
= 1;
4413 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4414 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4415 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4416 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4417 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4418 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4419 new_sym
->attr
.function
= sym
->attr
.function
;
4421 /* Ensure that the interface is available and that
4422 descriptors are passed for array actual arguments. */
4423 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4425 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4426 new_sym
->attr
.always_explicit
4427 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4430 /* Create a fake symtree for it. */
4432 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4433 new_symtree
->n
.sym
= new_sym
;
4434 gcc_assert (new_symtree
== root
);
4436 /* Create a dummy->actual mapping. */
4437 sm
= XCNEW (gfc_interface_sym_mapping
);
4438 sm
->next
= mapping
->syms
;
4440 sm
->new_sym
= new_symtree
;
4441 sm
->expr
= gfc_copy_expr (expr
);
4444 /* Stabilize the argument's value. */
4445 if (!sym
->attr
.function
&& se
)
4446 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4448 if (sym
->ts
.type
== BT_CHARACTER
)
4450 /* Create a copy of the dummy argument's length. */
4451 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4452 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4454 /* If the length is specified as "*", record the length that
4455 the caller is passing. We should use the callee's length
4456 in all other cases. */
4457 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4459 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4460 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4467 /* Use the passed value as-is if the argument is a function. */
4468 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4471 /* If the argument is a pass-by-value scalar, use the value as is. */
4472 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4475 /* If the argument is either a string or a pointer to a string,
4476 convert it to a boundless character type. */
4477 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4479 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4480 tmp
= build_pointer_type (tmp
);
4481 if (sym
->attr
.pointer
)
4482 value
= build_fold_indirect_ref_loc (input_location
,
4486 value
= fold_convert (tmp
, value
);
4489 /* If the argument is a scalar, a pointer to an array or an allocatable,
4491 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4492 value
= build_fold_indirect_ref_loc (input_location
,
4495 /* For character(*), use the actual argument's descriptor. */
4496 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4497 value
= build_fold_indirect_ref_loc (input_location
,
4500 /* If the argument is an array descriptor, use it to determine
4501 information about the actual argument's shape. */
4502 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4503 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4505 /* Get the actual argument's descriptor. */
4506 desc
= build_fold_indirect_ref_loc (input_location
,
4509 /* Create the replacement variable. */
4510 tmp
= gfc_conv_descriptor_data_get (desc
);
4511 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4514 /* Use DESC to work out the upper bounds, strides and offset. */
4515 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4518 /* Otherwise we have a packed array. */
4519 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4520 PACKED_FULL
, se
->expr
);
4522 new_sym
->backend_decl
= value
;
4526 /* Called once all dummy argument mappings have been added to MAPPING,
4527 but before the mapping is used to evaluate expressions. Pre-evaluate
4528 the length of each argument, adding any initialization code to PRE and
4529 any finalization code to POST. */
4532 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4533 stmtblock_t
* pre
, stmtblock_t
* post
)
4535 gfc_interface_sym_mapping
*sym
;
4539 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4540 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4541 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4543 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4544 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4545 gfc_init_se (&se
, NULL
);
4546 gfc_conv_expr (&se
, expr
);
4547 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4548 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4549 gfc_add_block_to_block (pre
, &se
.pre
);
4550 gfc_add_block_to_block (post
, &se
.post
);
4552 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4557 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4561 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4562 gfc_constructor_base base
)
4565 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4567 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4570 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4571 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4572 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4578 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4582 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4587 for (; ref
; ref
= ref
->next
)
4591 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4593 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4594 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4595 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4604 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4605 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4611 /* Convert intrinsic function calls into result expressions. */
4614 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4622 arg1
= expr
->value
.function
.actual
->expr
;
4623 if (expr
->value
.function
.actual
->next
)
4624 arg2
= expr
->value
.function
.actual
->next
->expr
;
4628 sym
= arg1
->symtree
->n
.sym
;
4630 if (sym
->attr
.dummy
)
4635 switch (expr
->value
.function
.isym
->id
)
4638 /* TODO figure out why this condition is necessary. */
4639 if (sym
->attr
.function
4640 && (arg1
->ts
.u
.cl
->length
== NULL
4641 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4642 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4645 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4648 case GFC_ISYM_LEN_TRIM
:
4649 new_expr
= gfc_copy_expr (arg1
);
4650 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4655 gfc_replace_expr (arg1
, new_expr
);
4659 if (!sym
->as
|| sym
->as
->rank
== 0)
4662 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4664 dup
= mpz_get_si (arg2
->value
.integer
);
4669 dup
= sym
->as
->rank
;
4673 for (; d
< dup
; d
++)
4677 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4679 gfc_free_expr (new_expr
);
4683 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4684 gfc_get_int_expr (gfc_default_integer_kind
,
4686 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4688 new_expr
= gfc_multiply (new_expr
, tmp
);
4694 case GFC_ISYM_LBOUND
:
4695 case GFC_ISYM_UBOUND
:
4696 /* TODO These implementations of lbound and ubound do not limit if
4697 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4699 if (!sym
->as
|| sym
->as
->rank
== 0)
4702 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4703 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4707 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4709 if (sym
->as
->lower
[d
])
4710 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4714 if (sym
->as
->upper
[d
])
4715 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4723 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4727 gfc_replace_expr (expr
, new_expr
);
4733 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4734 gfc_interface_mapping
* mapping
)
4736 gfc_formal_arglist
*f
;
4737 gfc_actual_arglist
*actual
;
4739 actual
= expr
->value
.function
.actual
;
4740 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4742 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4747 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4750 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4755 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4757 for (d
= 0; d
< as
->rank
; d
++)
4759 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4760 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4763 expr
->value
.function
.esym
->as
= as
;
4766 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4768 expr
->value
.function
.esym
->ts
.u
.cl
->length
4769 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4771 gfc_apply_interface_mapping_to_expr (mapping
,
4772 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4777 /* EXPR is a copy of an expression that appeared in the interface
4778 associated with MAPPING. Walk it recursively looking for references to
4779 dummy arguments that MAPPING maps to actual arguments. Replace each such
4780 reference with a reference to the associated actual argument. */
4783 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4786 gfc_interface_sym_mapping
*sym
;
4787 gfc_actual_arglist
*actual
;
4792 /* Copying an expression does not copy its length, so do that here. */
4793 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4795 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4796 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4799 /* Apply the mapping to any references. */
4800 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4802 /* ...and to the expression's symbol, if it has one. */
4803 /* TODO Find out why the condition on expr->symtree had to be moved into
4804 the loop rather than being outside it, as originally. */
4805 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4806 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4808 if (sym
->new_sym
->n
.sym
->backend_decl
)
4809 expr
->symtree
= sym
->new_sym
;
4811 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4814 /* ...and to subexpressions in expr->value. */
4815 switch (expr
->expr_type
)
4820 case EXPR_SUBSTRING
:
4824 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4825 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4829 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4830 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4832 if (expr
->value
.function
.esym
== NULL
4833 && expr
->value
.function
.isym
!= NULL
4834 && expr
->value
.function
.actual
4835 && expr
->value
.function
.actual
->expr
4836 && expr
->value
.function
.actual
->expr
->symtree
4837 && gfc_map_intrinsic_function (expr
, mapping
))
4840 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4841 if (sym
->old
== expr
->value
.function
.esym
)
4843 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4844 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4845 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4850 case EXPR_STRUCTURE
:
4851 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4865 /* Evaluate interface expression EXPR using MAPPING. Store the result
4869 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4870 gfc_se
* se
, gfc_expr
* expr
)
4872 expr
= gfc_copy_expr (expr
);
4873 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4874 gfc_conv_expr (se
, expr
);
4875 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4876 gfc_free_expr (expr
);
4880 /* Returns a reference to a temporary array into which a component of
4881 an actual argument derived type array is copied and then returned
4882 after the function call. */
4884 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4885 sym_intent intent
, bool formal_ptr
,
4886 const gfc_symbol
*fsym
, const char *proc_name
,
4887 gfc_symbol
*sym
, bool check_contiguous
)
4895 gfc_array_info
*info
;
4908 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4910 if (pass_optional
|| check_contiguous
)
4912 gfc_init_se (&work_se
, NULL
);
4918 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4920 /* We will create a temporary array, so let us warn. */
4923 if (fsym
&& proc_name
)
4924 msg
= xasprintf ("An array temporary was created for argument "
4925 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4927 msg
= xasprintf ("An array temporary was created");
4929 tmp
= build_int_cst (logical_type_node
, 1);
4930 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4935 gfc_init_se (&lse
, NULL
);
4936 gfc_init_se (&rse
, NULL
);
4938 /* Walk the argument expression. */
4939 rss
= gfc_walk_expr (expr
);
4941 gcc_assert (rss
!= gfc_ss_terminator
);
4943 /* Initialize the scalarizer. */
4944 gfc_init_loopinfo (&loop
);
4945 gfc_add_ss_to_loop (&loop
, rss
);
4947 /* Calculate the bounds of the scalarization. */
4948 gfc_conv_ss_startstride (&loop
);
4950 /* Build an ss for the temporary. */
4951 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4952 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4954 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4955 if (GFC_ARRAY_TYPE_P (base_type
)
4956 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4957 base_type
= gfc_get_element_type (base_type
);
4959 if (expr
->ts
.type
== BT_CLASS
)
4960 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4962 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4963 ? expr
->ts
.u
.cl
->backend_decl
4967 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4969 /* Associate the SS with the loop. */
4970 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4972 /* Setup the scalarizing loops. */
4973 gfc_conv_loop_setup (&loop
, &expr
->where
);
4975 /* Pass the temporary descriptor back to the caller. */
4976 info
= &loop
.temp_ss
->info
->data
.array
;
4977 parmse
->expr
= info
->descriptor
;
4979 /* Setup the gfc_se structures. */
4980 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4981 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4984 lse
.ss
= loop
.temp_ss
;
4985 gfc_mark_ss_chain_used (rss
, 1);
4986 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4988 /* Start the scalarized loop body. */
4989 gfc_start_scalarized_body (&loop
, &body
);
4991 /* Translate the expression. */
4992 gfc_conv_expr (&rse
, expr
);
4994 /* Reset the offset for the function call since the loop
4995 is zero based on the data pointer. Note that the temp
4996 comes first in the loop chain since it is added second. */
4997 if (gfc_is_class_array_function (expr
))
4999 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
5000 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
5001 gfc_index_zero_node
);
5004 gfc_conv_tmp_array_ref (&lse
);
5006 if (intent
!= INTENT_OUT
)
5008 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
5009 gfc_add_expr_to_block (&body
, tmp
);
5010 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5011 gfc_trans_scalarizing_loops (&loop
, &body
);
5015 /* Make sure that the temporary declaration survives by merging
5016 all the loop declarations into the current context. */
5017 for (n
= 0; n
< loop
.dimen
; n
++)
5019 gfc_merge_block_scope (&body
);
5020 body
= loop
.code
[loop
.order
[n
]];
5022 gfc_merge_block_scope (&body
);
5025 /* Add the post block after the second loop, so that any
5026 freeing of allocated memory is done at the right time. */
5027 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
5029 /**********Copy the temporary back again.*********/
5031 gfc_init_se (&lse
, NULL
);
5032 gfc_init_se (&rse
, NULL
);
5034 /* Walk the argument expression. */
5035 lss
= gfc_walk_expr (expr
);
5036 rse
.ss
= loop
.temp_ss
;
5039 /* Initialize the scalarizer. */
5040 gfc_init_loopinfo (&loop2
);
5041 gfc_add_ss_to_loop (&loop2
, lss
);
5043 dimen
= rse
.ss
->dimen
;
5045 /* Skip the write-out loop for this case. */
5046 if (gfc_is_class_array_function (expr
))
5047 goto class_array_fcn
;
5049 /* Calculate the bounds of the scalarization. */
5050 gfc_conv_ss_startstride (&loop2
);
5052 /* Setup the scalarizing loops. */
5053 gfc_conv_loop_setup (&loop2
, &expr
->where
);
5055 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
5056 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
5058 gfc_mark_ss_chain_used (lss
, 1);
5059 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5061 /* Declare the variable to hold the temporary offset and start the
5062 scalarized loop body. */
5063 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
5064 gfc_start_scalarized_body (&loop2
, &body
);
5066 /* Build the offsets for the temporary from the loop variables. The
5067 temporary array has lbounds of zero and strides of one in all
5068 dimensions, so this is very simple. The offset is only computed
5069 outside the innermost loop, so the overall transfer could be
5070 optimized further. */
5071 info
= &rse
.ss
->info
->data
.array
;
5073 tmp_index
= gfc_index_zero_node
;
5074 for (n
= dimen
- 1; n
> 0; n
--)
5077 tmp
= rse
.loop
->loopvar
[n
];
5078 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5079 tmp
, rse
.loop
->from
[n
]);
5080 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5083 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
5084 gfc_array_index_type
,
5085 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
5086 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
5087 gfc_array_index_type
,
5088 tmp_str
, gfc_index_one_node
);
5090 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
5091 gfc_array_index_type
, tmp
, tmp_str
);
5094 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
5095 gfc_array_index_type
,
5096 tmp_index
, rse
.loop
->from
[0]);
5097 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
5099 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5100 gfc_array_index_type
,
5101 rse
.loop
->loopvar
[0], offset
);
5103 /* Now use the offset for the reference. */
5104 tmp
= build_fold_indirect_ref_loc (input_location
,
5106 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
5108 if (expr
->ts
.type
== BT_CHARACTER
)
5109 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
5111 gfc_conv_expr (&lse
, expr
);
5113 gcc_assert (lse
.ss
== gfc_ss_terminator
);
5115 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
5116 gfc_add_expr_to_block (&body
, tmp
);
5118 /* Generate the copying loops. */
5119 gfc_trans_scalarizing_loops (&loop2
, &body
);
5121 /* Wrap the whole thing up by adding the second loop to the post-block
5122 and following it by the post-block of the first loop. In this way,
5123 if the temporary needs freeing, it is done after use! */
5124 if (intent
!= INTENT_IN
)
5126 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
5127 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
5132 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
5134 gfc_cleanup_loop (&loop
);
5135 gfc_cleanup_loop (&loop2
);
5137 /* Pass the string length to the argument expression. */
5138 if (expr
->ts
.type
== BT_CHARACTER
)
5139 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5141 /* Determine the offset for pointer formal arguments and set the
5145 size
= gfc_index_one_node
;
5146 offset
= gfc_index_zero_node
;
5147 for (n
= 0; n
< dimen
; n
++)
5149 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
5151 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5152 gfc_array_index_type
, tmp
,
5153 gfc_index_one_node
);
5154 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
5158 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
5161 gfc_index_one_node
);
5162 size
= gfc_evaluate_now (size
, &parmse
->pre
);
5163 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5164 gfc_array_index_type
,
5166 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
5167 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5168 gfc_array_index_type
,
5169 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
5170 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5171 gfc_array_index_type
,
5172 tmp
, gfc_index_one_node
);
5173 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5174 gfc_array_index_type
, size
, tmp
);
5177 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
5181 /* We want either the address for the data or the address of the descriptor,
5182 depending on the mode of passing array arguments. */
5184 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
5186 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5188 /* Basically make this into
5199 pointer = parmse->expr;
5206 if (present && !contiguous)
5211 if (pass_optional
|| check_contiguous
)
5214 stmtblock_t else_block
;
5215 tree pre_stmts
, post_stmts
;
5218 tree present_var
= NULL_TREE
;
5219 tree cont_var
= NULL_TREE
;
5222 type
= TREE_TYPE (parmse
->expr
);
5223 if (POINTER_TYPE_P (type
) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
5224 type
= TREE_TYPE (type
);
5225 pointer
= gfc_create_var (type
, "arg_ptr");
5227 if (check_contiguous
)
5229 gfc_se cont_se
, array_se
;
5230 stmtblock_t if_block
, else_block
;
5231 tree if_stmt
, else_stmt
;
5235 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
5237 /* If the size is known to be one at compile-time, set
5238 cont_var to true unconditionally. This may look
5239 inelegant, but we're only doing this during
5240 optimization, so the statements will be optimized away,
5241 and this saves complexity here. */
5243 size_set
= gfc_array_size (expr
, &size
);
5244 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
5246 gfc_add_modify (&se
->pre
, cont_var
,
5247 build_one_cst (boolean_type_node
));
5251 /* cont_var = is_contiguous (expr); . */
5252 gfc_init_se (&cont_se
, parmse
);
5253 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
5254 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
5255 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
5256 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
5262 /* arrayse->expr = descriptor of a. */
5263 gfc_init_se (&array_se
, se
);
5264 gfc_conv_expr_descriptor (&array_se
, expr
);
5265 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
5266 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
5268 /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5269 gfc_init_block (&if_block
);
5270 if (GFC_DESCRIPTOR_TYPE_P (type
))
5271 gfc_add_modify (&if_block
, pointer
, array_se
.expr
);
5274 tmp
= gfc_conv_array_data (array_se
.expr
);
5275 tmp
= fold_convert (type
, tmp
);
5276 gfc_add_modify (&if_block
, pointer
, tmp
);
5278 if_stmt
= gfc_finish_block (&if_block
);
5280 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5281 gfc_init_block (&else_block
);
5282 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
5283 tmp
= (GFC_DESCRIPTOR_TYPE_P (type
)
5284 ? build_fold_indirect_ref_loc (input_location
, parmse
->expr
)
5286 gfc_add_modify (&else_block
, pointer
, tmp
);
5287 else_stmt
= gfc_finish_block (&else_block
);
5289 /* And put the above into an if statement. */
5290 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5291 gfc_likely (cont_var
,
5292 PRED_FORTRAN_CONTIGUOUS
),
5293 if_stmt
, else_stmt
);
5297 /* pointer = pramse->expr; . */
5298 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5299 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5304 present_var
= gfc_create_var (boolean_type_node
, "present");
5306 /* present_var = present(sym); . */
5307 tmp
= gfc_conv_expr_present (sym
);
5308 tmp
= fold_convert (boolean_type_node
, tmp
);
5309 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5311 /* else_stmt = { pointer = NULL; } . */
5312 gfc_init_block (&else_block
);
5313 if (GFC_DESCRIPTOR_TYPE_P (type
))
5314 gfc_conv_descriptor_data_set (&else_block
, pointer
,
5317 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5318 else_stmt
= gfc_finish_block (&else_block
);
5320 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5321 gfc_likely (present_var
,
5322 PRED_FORTRAN_ABSENT_DUMMY
),
5323 pre_stmts
, else_stmt
);
5324 gfc_add_expr_to_block (&se
->pre
, tmp
);
5327 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5329 post_stmts
= gfc_finish_block (&parmse
->post
);
5331 /* Put together the post stuff, plus the optional
5333 if (check_contiguous
)
5336 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5338 build_zero_cst (boolean_type_node
));
5339 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5343 tree present_likely
= gfc_likely (present_var
,
5344 PRED_FORTRAN_ABSENT_DUMMY
);
5345 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5346 boolean_type_node
, present_likely
,
5354 gcc_assert (pass_optional
);
5355 post_cond
= present_var
;
5358 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5359 post_stmts
, build_empty_stmt (input_location
));
5360 gfc_add_expr_to_block (&se
->post
, tmp
);
5361 if (GFC_DESCRIPTOR_TYPE_P (type
))
5363 type
= TREE_TYPE (parmse
->expr
);
5364 if (POINTER_TYPE_P (type
))
5366 pointer
= gfc_build_addr_expr (type
, pointer
);
5369 tmp
= gfc_likely (present_var
, PRED_FORTRAN_ABSENT_DUMMY
);
5370 pointer
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5373 null_pointer_node
));
5377 gcc_assert (!pass_optional
);
5386 /* Generate the code for argument list functions. */
5389 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5391 /* Pass by value for g77 %VAL(arg), pass the address
5392 indirectly for %LOC, else by reference. Thus %REF
5393 is a "do-nothing" and %LOC is the same as an F95
5395 if (strcmp (name
, "%VAL") == 0)
5396 gfc_conv_expr (se
, expr
);
5397 else if (strcmp (name
, "%LOC") == 0)
5399 gfc_conv_expr_reference (se
, expr
);
5400 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5402 else if (strcmp (name
, "%REF") == 0)
5403 gfc_conv_expr_reference (se
, expr
);
5405 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5409 /* This function tells whether the middle-end representation of the expression
5410 E given as input may point to data otherwise accessible through a variable
5412 It is assumed that the only expressions that may alias are variables,
5413 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5415 This function is used to decide whether freeing an expression's allocatable
5416 components is safe or should be avoided.
5418 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5419 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5420 is necessary because for array constructors, aliasing depends on how
5422 - If E is an array constructor used as argument to an elemental procedure,
5423 the array, which is generated through shallow copy by the scalarizer,
5424 is used directly and can alias the expressions it was copied from.
5425 - If E is an array constructor used as argument to a non-elemental
5426 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5427 the array as in the previous case, but then that array is used
5428 to initialize a new descriptor through deep copy. There is no alias
5429 possible in that case.
5430 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5434 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5438 if (e
->expr_type
== EXPR_VARIABLE
)
5440 else if (e
->expr_type
== EXPR_FUNCTION
)
5442 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5444 if (proc_ifc
->result
!= NULL
5445 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5446 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5447 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5448 || proc_ifc
->result
->attr
.pointer
))
5453 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5456 for (c
= gfc_constructor_first (e
->value
.constructor
);
5457 c
; c
= gfc_constructor_next (c
))
5459 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5466 /* A helper function to set the dtype for unallocated or unassociated
5470 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5478 /* TODO Figure out how to handle optional dummies. */
5479 if (e
&& e
->expr_type
== EXPR_VARIABLE
5480 && e
->symtree
->n
.sym
->attr
.optional
)
5483 desc
= parmse
->expr
;
5484 if (desc
== NULL_TREE
)
5487 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5488 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5489 if (GFC_CLASS_TYPE_P (TREE_TYPE (desc
)))
5490 desc
= gfc_class_data_get (desc
);
5491 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5494 gfc_init_block (&block
);
5495 tmp
= gfc_conv_descriptor_data_get (desc
);
5496 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5497 logical_type_node
, tmp
,
5498 build_int_cst (TREE_TYPE (tmp
), 0));
5499 tmp
= gfc_conv_descriptor_dtype (desc
);
5500 type
= gfc_get_element_type (TREE_TYPE (desc
));
5501 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5502 TREE_TYPE (tmp
), tmp
,
5503 gfc_get_dtype_rank_type (e
->rank
, type
));
5504 gfc_add_expr_to_block (&block
, tmp
);
5505 cond
= build3_v (COND_EXPR
, cond
,
5506 gfc_finish_block (&block
),
5507 build_empty_stmt (input_location
));
5508 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5513 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5514 ISO_Fortran_binding array descriptors. */
5517 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5519 stmtblock_t block
, block2
;
5520 tree cfi
, gfc
, tmp
, tmp2
;
5521 tree present
= NULL
;
5522 tree gfc_strlen
= NULL
;
5526 if (fsym
->attr
.optional
5527 && e
->expr_type
== EXPR_VARIABLE
5528 && e
->symtree
->n
.sym
->attr
.optional
)
5529 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5531 gfc_init_block (&block
);
5533 /* Convert original argument to a tree. */
5534 gfc_init_se (&se
, NULL
);
5537 se
.want_pointer
= 1;
5538 gfc_conv_expr (&se
, e
);
5540 /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5541 if (!POINTER_TYPE_P (TREE_TYPE (gfc
)))
5542 gfc
= gfc_build_addr_expr (NULL
, gfc
);
5546 /* If the actual argument can be noncontiguous, copy-in/out is required,
5547 if the dummy has either the CONTIGUOUS attribute or is an assumed-
5548 length assumed-length/assumed-size CHARACTER array. This only
5549 applies if the actual argument is a "variable"; if it's some
5550 non-lvalue expression, we are going to evaluate it to a
5551 temporary below anyway. */
5552 se
.force_no_tmp
= 1;
5553 if ((fsym
->attr
.contiguous
5554 || (fsym
->ts
.type
== BT_CHARACTER
&& !fsym
->ts
.u
.cl
->length
5555 && (fsym
->as
->type
== AS_ASSUMED_SIZE
5556 || fsym
->as
->type
== AS_EXPLICIT
)))
5557 && !gfc_is_simply_contiguous (e
, false, true)
5558 && gfc_expr_is_variable (e
))
5560 bool optional
= fsym
->attr
.optional
;
5561 fsym
->attr
.optional
= 0;
5562 gfc_conv_subref_array_arg (&se
, e
, false, fsym
->attr
.intent
,
5563 fsym
->attr
.pointer
, fsym
,
5564 fsym
->ns
->proc_name
->name
, NULL
,
5565 /* check_contiguous= */ true);
5566 fsym
->attr
.optional
= optional
;
5569 gfc_conv_expr_descriptor (&se
, e
);
5571 /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5572 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5573 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5574 While sm is fine as it uses span*stride and not elem_len. */
5575 if (POINTER_TYPE_P (TREE_TYPE (gfc
)))
5576 gfc
= build_fold_indirect_ref_loc (input_location
, gfc
);
5577 else if (is_subref_array (e
) && e
->ts
.type
!= BT_CHARACTER
)
5578 gfc_get_dataptr_offset (&se
.pre
, gfc
, gfc
, NULL
, true, e
);
5580 if (e
->ts
.type
== BT_CHARACTER
)
5582 if (se
.string_length
)
5583 gfc_strlen
= se
.string_length
;
5584 else if (e
->ts
.u
.cl
->backend_decl
)
5585 gfc_strlen
= e
->ts
.u
.cl
->backend_decl
;
5589 gfc_add_block_to_block (&block
, &se
.pre
);
5591 /* Create array decriptor and set version, rank, attribute, type. */
5592 cfi
= gfc_create_var (gfc_get_cfi_type (e
->rank
< 0
5593 ? GFC_MAX_DIMENSIONS
: e
->rank
,
5595 /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5596 if (fsym
->attr
.dimension
&& fsym
->as
->type
== AS_ASSUMED_RANK
)
5598 tmp
= gfc_get_cfi_type (-1, !fsym
->attr
.pointer
&& !fsym
->attr
.target
);
5599 tmp
= build_pointer_type (tmp
);
5600 parmse
->expr
= cfi
= gfc_build_addr_expr (tmp
, cfi
);
5601 cfi
= build_fold_indirect_ref_loc (input_location
, cfi
);
5604 parmse
->expr
= gfc_build_addr_expr (NULL
, cfi
);
5606 tmp
= gfc_get_cfi_desc_version (cfi
);
5607 gfc_add_modify (&block
, tmp
,
5608 build_int_cst (TREE_TYPE (tmp
), CFI_VERSION
));
5610 rank
= fold_convert (signed_char_type_node
, gfc_conv_descriptor_rank (gfc
));
5612 rank
= build_int_cst (signed_char_type_node
, e
->rank
);
5613 tmp
= gfc_get_cfi_desc_rank (cfi
);
5614 gfc_add_modify (&block
, tmp
, rank
);
5615 int itype
= CFI_type_other
;
5616 if (e
->ts
.f90_type
== BT_VOID
)
5617 itype
= (e
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
5618 ? CFI_type_cfunptr
: CFI_type_cptr
);
5621 if (e
->expr_type
== EXPR_NULL
&& e
->ts
.type
== BT_UNKNOWN
)
5629 itype
= CFI_type_from_type_kind (e
->ts
.type
, e
->ts
.kind
);
5632 itype
= CFI_type_from_type_kind (CFI_type_Character
, e
->ts
.kind
);
5635 itype
= CFI_type_struct
;
5638 itype
= (e
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
5639 ? CFI_type_cfunptr
: CFI_type_cptr
);
5642 itype
= CFI_type_other
; // FIXME: Or CFI_type_cptr ?
5645 if (UNLIMITED_POLY (e
) && fsym
->ts
.type
== BT_ASSUMED
)
5647 // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
5648 // type specifier is assumed-type and is an unlimited polymorphic
5649 // entity." The actual argument _data component is passed.
5650 itype
= CFI_type_other
; // FIXME: Or CFI_type_cptr ?
5660 // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5665 tmp
= gfc_get_cfi_desc_type (cfi
);
5666 gfc_add_modify (&block
, tmp
,
5667 build_int_cst (TREE_TYPE (tmp
), itype
));
5669 int attr
= CFI_attribute_other
;
5670 if (fsym
->attr
.pointer
)
5671 attr
= CFI_attribute_pointer
;
5672 else if (fsym
->attr
.allocatable
)
5673 attr
= CFI_attribute_allocatable
;
5674 tmp
= gfc_get_cfi_desc_attribute (cfi
);
5675 gfc_add_modify (&block
, tmp
,
5676 build_int_cst (TREE_TYPE (tmp
), attr
));
5678 /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
5679 That is very sensible for undefined pointers, but the C code might assume
5680 that the pointer retains the value, in particular, if it was NULL. */
5683 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5684 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), gfc
));
5688 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5689 tmp2
= gfc_conv_descriptor_data_get (gfc
);
5690 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
5693 /* Set elem_len if known - must be before the next if block.
5694 Note that allocatable implies 'len=:'. */
5695 if (e
->ts
.type
!= BT_ASSUMED
&& e
->ts
.type
!= BT_CHARACTER
)
5697 /* Length is known at compile time; use 'block' for it. */
5698 tmp
= size_in_bytes (gfc_typenode_for_spec (&e
->ts
));
5699 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5700 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5703 if (fsym
->attr
.pointer
&& fsym
->attr
.intent
== INTENT_OUT
)
5706 /* When allocatable + intent out, free the cfi descriptor. */
5707 if (fsym
->attr
.allocatable
&& fsym
->attr
.intent
== INTENT_OUT
)
5709 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5710 tree call
= builtin_decl_explicit (BUILT_IN_FREE
);
5711 call
= build_call_expr_loc (input_location
, call
, 1, tmp
);
5712 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
5713 gfc_add_modify (&block
, tmp
,
5714 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5718 /* If not unallocated/unassociated. */
5719 gfc_init_block (&block2
);
5721 /* Set elem_len, which may be only known at run time. */
5722 if (e
->ts
.type
== BT_CHARACTER
5723 && (e
->expr_type
!= EXPR_NULL
|| gfc_strlen
!= NULL_TREE
))
5725 gcc_assert (gfc_strlen
);
5727 if (e
->ts
.kind
!= 1)
5728 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5729 gfc_charlen_type_node
, tmp
,
5730 build_int_cst (gfc_charlen_type_node
,
5732 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5733 gfc_add_modify (&block2
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5735 else if (e
->ts
.type
== BT_ASSUMED
)
5737 tmp
= gfc_conv_descriptor_elem_len (gfc
);
5738 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5739 gfc_add_modify (&block2
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5742 if (e
->ts
.type
== BT_ASSUMED
)
5744 /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5745 an CFI descriptor. Use the type in the descritor as it provide
5746 mode information. (Quality of implementation feature.) */
5748 tree ctype
= gfc_get_cfi_desc_type (cfi
);
5749 tree type
= fold_convert (TREE_TYPE (ctype
),
5750 gfc_conv_descriptor_type (gfc
));
5751 tree kind
= fold_convert (TREE_TYPE (ctype
),
5752 gfc_conv_descriptor_elem_len (gfc
));
5753 kind
= fold_build2_loc (input_location
, LSHIFT_EXPR
, TREE_TYPE (type
),
5754 kind
, build_int_cst (TREE_TYPE (type
),
5755 CFI_type_kind_shift
));
5757 /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5758 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5759 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5760 build_int_cst (TREE_TYPE (type
), BT_VOID
));
5761 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, ctype
,
5762 build_int_cst (TREE_TYPE (type
), CFI_type_cptr
));
5763 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5765 build_int_cst (TREE_TYPE (type
), CFI_type_other
));
5766 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5768 /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5769 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5770 build_int_cst (TREE_TYPE (type
), BT_DERIVED
));
5771 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, ctype
,
5772 build_int_cst (TREE_TYPE (type
), CFI_type_struct
));
5773 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5775 /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5776 /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5777 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5778 build_int_cst (TREE_TYPE (type
), BT_CHARACTER
));
5779 tmp
= build_int_cst (TREE_TYPE (type
),
5780 CFI_type_from_type_kind (CFI_type_Character
, 1));
5781 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5783 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5785 /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5786 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5787 build_int_cst (TREE_TYPE (type
), BT_COMPLEX
));
5788 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (type
),
5789 kind
, build_int_cst (TREE_TYPE (type
), 2));
5790 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (type
), tmp
,
5791 build_int_cst (TREE_TYPE (type
),
5793 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5795 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5797 /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5798 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5799 build_int_cst (TREE_TYPE (type
), BT_INTEGER
));
5800 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5801 build_int_cst (TREE_TYPE (type
), BT_LOGICAL
));
5802 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
5804 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5805 build_int_cst (TREE_TYPE (type
), BT_REAL
));
5806 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
5808 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (type
),
5810 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5812 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5814 gfc_add_expr_to_block (&block2
, tmp2
);
5819 /* Loop: for (i = 0; i < rank; ++i). */
5820 tree idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
5822 stmtblock_t loop_body
;
5823 gfc_init_block (&loop_body
);
5824 /* cfi->dim[i].lower_bound = (allocatable/pointer)
5825 ? gfc->dim[i].lbound : 0 */
5826 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5827 tmp
= gfc_conv_descriptor_lbound_get (gfc
, idx
);
5829 tmp
= gfc_index_zero_node
;
5830 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_lbound (cfi
, idx
), tmp
);
5831 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5832 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5833 gfc_conv_descriptor_ubound_get (gfc
, idx
),
5834 gfc_conv_descriptor_lbound_get (gfc
, idx
));
5835 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5836 tmp
, gfc_index_one_node
);
5837 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
5838 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5839 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5840 gfc_conv_descriptor_stride_get (gfc
, idx
),
5841 gfc_conv_descriptor_span_get (gfc
));
5842 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_sm (cfi
, idx
), tmp
);
5844 /* Generate loop. */
5845 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 0),
5846 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
5847 gfc_finish_block (&loop_body
));
5849 if (e
->expr_type
== EXPR_VARIABLE
5851 && e
->ref
->u
.ar
.type
== AR_FULL
5852 && e
->symtree
->n
.sym
->attr
.dummy
5853 && e
->symtree
->n
.sym
->as
5854 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
5856 tmp
= gfc_get_cfi_dim_extent (cfi
, gfc_rank_cst
[e
->rank
-1]),
5857 gfc_add_modify (&block2
, tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
5861 if (fsym
->attr
.allocatable
|| fsym
->attr
.pointer
)
5863 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
5864 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5865 tmp
, null_pointer_node
);
5866 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
5867 build_empty_stmt (input_location
));
5868 gfc_add_expr_to_block (&block
, tmp
);
5871 gfc_add_block_to_block (&block
, &block2
);
5877 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
5878 TREE_TYPE (parmse
->expr
),
5879 present
, parmse
->expr
, null_pointer_node
);
5880 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
),
5881 build_empty_stmt (input_location
));
5882 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5885 gfc_add_block_to_block (&parmse
->pre
, &block
);
5887 gfc_init_block (&block
);
5889 if ((!fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
)
5890 || fsym
->attr
.intent
== INTENT_IN
)
5893 gfc_init_block (&block2
);
5896 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5897 gfc_add_modify (&block
, gfc
, fold_convert (TREE_TYPE (gfc
), tmp
));
5901 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5902 gfc_conv_descriptor_data_set (&block
, gfc
, tmp
);
5904 if (fsym
->attr
.allocatable
)
5906 /* gfc->span = cfi->elem_len. */
5907 tmp
= fold_convert (gfc_array_index_type
,
5908 gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]));
5912 /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5913 ? cfi->dim[0].sm : cfi->elem_len). */
5914 tmp
= gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]);
5915 tmp2
= fold_convert (gfc_array_index_type
,
5916 gfc_get_cfi_desc_elem_len (cfi
));
5917 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
5918 gfc_array_index_type
, tmp
, tmp2
);
5919 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5920 tmp
, gfc_index_zero_node
);
5921 tmp
= build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, tmp
,
5922 gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]), tmp2
);
5924 gfc_conv_descriptor_span_set (&block2
, gfc
, tmp
);
5926 /* Calculate offset + set lbound, ubound and stride. */
5927 gfc_conv_descriptor_offset_set (&block2
, gfc
, gfc_index_zero_node
);
5928 /* Loop: for (i = 0; i < rank; ++i). */
5929 tree idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
5931 stmtblock_t loop_body
;
5932 gfc_init_block (&loop_body
);
5933 /* gfc->dim[i].lbound = ... */
5934 tmp
= gfc_get_cfi_dim_lbound (cfi
, idx
);
5935 gfc_conv_descriptor_lbound_set (&loop_body
, gfc
, idx
, tmp
);
5937 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
5938 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5939 gfc_conv_descriptor_lbound_get (gfc
, idx
),
5940 gfc_index_one_node
);
5941 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5942 gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
5943 gfc_conv_descriptor_ubound_set (&loop_body
, gfc
, idx
, tmp
);
5945 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
5946 tmp
= gfc_get_cfi_dim_sm (cfi
, idx
);
5947 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5948 gfc_array_index_type
, tmp
,
5949 fold_convert (gfc_array_index_type
,
5950 gfc_get_cfi_desc_elem_len (cfi
)));
5951 gfc_conv_descriptor_stride_set (&loop_body
, gfc
, idx
, tmp
);
5953 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
5954 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5955 gfc_conv_descriptor_stride_get (gfc
, idx
),
5956 gfc_conv_descriptor_lbound_get (gfc
, idx
));
5957 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5958 gfc_conv_descriptor_offset_get (gfc
), tmp
);
5959 gfc_conv_descriptor_offset_set (&loop_body
, gfc
, tmp
);
5960 /* Generate loop. */
5961 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 0),
5962 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
5963 gfc_finish_block (&loop_body
));
5966 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
5968 tmp
= fold_convert (gfc_charlen_type_node
,
5969 gfc_get_cfi_desc_elem_len (cfi
));
5970 if (e
->ts
.kind
!= 1)
5971 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5972 gfc_charlen_type_node
, tmp
,
5973 build_int_cst (gfc_charlen_type_node
,
5975 gfc_add_modify (&block2
, gfc_strlen
, tmp
);
5978 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
5979 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5980 tmp
, null_pointer_node
);
5981 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
5982 build_empty_stmt (input_location
));
5983 gfc_add_expr_to_block (&block
, tmp
);
5986 gfc_add_block_to_block (&block
, &se
.post
);
5987 if (present
&& block
.head
)
5989 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
),
5990 build_empty_stmt (input_location
));
5991 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5993 else if (block
.head
)
5994 gfc_add_block_to_block (&parmse
->post
, &block
);
5998 /* Generate code for a procedure call. Note can return se->post != NULL.
5999 If se->direct_byref is set then se->expr contains the return parameter.
6000 Return nonzero, if the call has alternate specifiers.
6001 'expr' is only needed for procedure pointer components. */
6004 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
6005 gfc_actual_arglist
* args
, gfc_expr
* expr
,
6006 vec
<tree
, va_gc
> *append_args
)
6008 gfc_interface_mapping mapping
;
6009 vec
<tree
, va_gc
> *arglist
;
6010 vec
<tree
, va_gc
> *retargs
;
6014 gfc_array_info
*info
;
6021 vec
<tree
, va_gc
> *stringargs
;
6022 vec
<tree
, va_gc
> *optionalargs
;
6024 gfc_formal_arglist
*formal
;
6025 gfc_actual_arglist
*arg
;
6026 int has_alternate_specifier
= 0;
6027 bool need_interface_mapping
;
6034 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
6035 gfc_component
*comp
= NULL
;
6042 optionalargs
= NULL
;
6047 comp
= gfc_get_proc_ptr_comp (expr
);
6049 bool elemental_proc
= (comp
6050 && comp
->ts
.interface
6051 && comp
->ts
.interface
->attr
.elemental
)
6052 || (comp
&& comp
->attr
.elemental
)
6053 || sym
->attr
.elemental
;
6057 if (!elemental_proc
)
6059 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
6060 if (se
->ss
->info
->useflags
)
6062 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
6063 && sym
->result
->attr
.dimension
)
6064 || (comp
&& comp
->attr
.dimension
)
6065 || gfc_is_class_array_function (expr
));
6066 gcc_assert (se
->loop
!= NULL
);
6067 /* Access the previously obtained result. */
6068 gfc_conv_tmp_array_ref (se
);
6072 info
= &se
->ss
->info
->data
.array
;
6077 stmtblock_t post
, clobbers
;
6078 gfc_init_block (&post
);
6079 gfc_init_block (&clobbers
);
6080 gfc_init_interface_mapping (&mapping
);
6083 formal
= gfc_sym_get_dummy_args (sym
);
6084 need_interface_mapping
= sym
->attr
.dimension
||
6085 (sym
->ts
.type
== BT_CHARACTER
6086 && sym
->ts
.u
.cl
->length
6087 && sym
->ts
.u
.cl
->length
->expr_type
6092 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
6093 need_interface_mapping
= comp
->attr
.dimension
||
6094 (comp
->ts
.type
== BT_CHARACTER
6095 && comp
->ts
.u
.cl
->length
6096 && comp
->ts
.u
.cl
->length
->expr_type
6100 base_object
= NULL_TREE
;
6101 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6102 is the third and fourth argument to such a function call a value
6103 denoting the number of elements to copy (i.e., most of the time the
6104 length of a deferred length string). */
6105 ulim_copy
= (formal
== NULL
)
6106 && UNLIMITED_POLY (sym
)
6107 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
6109 /* Evaluate the arguments. */
6110 for (arg
= args
, argc
= 0; arg
!= NULL
;
6111 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
6113 bool finalized
= false;
6114 tree derived_array
= NULL_TREE
;
6117 fsym
= formal
? formal
->sym
: NULL
;
6118 parm_kind
= MISSING
;
6120 /* If the procedure requires an explicit interface, the actual
6121 argument is passed according to the corresponding formal
6122 argument. If the corresponding formal argument is a POINTER,
6123 ALLOCATABLE or assumed shape, we do not use g77's calling
6124 convention, and pass the address of the array descriptor
6125 instead. Otherwise we use g77's calling convention, in other words
6126 pass the array data pointer without descriptor. */
6127 bool nodesc_arg
= fsym
!= NULL
6128 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
6130 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
6131 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
6133 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
6135 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
6137 /* Class array expressions are sometimes coming completely unadorned
6138 with either arrayspec or _data component. Correct that here.
6139 OOP-TODO: Move this to the frontend. */
6140 if (e
&& e
->expr_type
== EXPR_VARIABLE
6142 && e
->ts
.type
== BT_CLASS
6143 && (CLASS_DATA (e
)->attr
.codimension
6144 || CLASS_DATA (e
)->attr
.dimension
))
6146 gfc_typespec temp_ts
= e
->ts
;
6147 gfc_add_class_array_ref (e
);
6153 if (se
->ignore_optional
)
6155 /* Some intrinsics have already been resolved to the correct
6159 else if (arg
->label
)
6161 has_alternate_specifier
= 1;
6166 gfc_init_se (&parmse
, NULL
);
6168 /* For scalar arguments with VALUE attribute which are passed by
6169 value, pass "0" and a hidden argument gives the optional
6171 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
6172 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CLASS
6173 && !gfc_bt_struct (sym
->ts
.type
))
6175 if (fsym
->ts
.type
== BT_CHARACTER
)
6177 /* Pass a NULL pointer for an absent CHARACTER arg
6178 and a length of zero. */
6179 parmse
.expr
= null_pointer_node
;
6180 parmse
.string_length
6181 = build_int_cst (gfc_charlen_type_node
,
6185 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
6187 vec_safe_push (optionalargs
, boolean_false_node
);
6191 /* Pass a NULL pointer for an absent arg. */
6192 parmse
.expr
= null_pointer_node
;
6193 gfc_dummy_arg
* const dummy_arg
= arg
->associated_dummy
;
6195 && gfc_dummy_arg_get_typespec (*dummy_arg
).type
6197 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
6202 else if (arg
->expr
->expr_type
== EXPR_NULL
6203 && fsym
&& !fsym
->attr
.pointer
6204 && (fsym
->ts
.type
!= BT_CLASS
6205 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
6207 /* Pass a NULL pointer to denote an absent arg. */
6208 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
6209 && (fsym
->ts
.type
!= BT_CLASS
6210 || !CLASS_DATA (fsym
)->attr
.allocatable
));
6211 gfc_init_se (&parmse
, NULL
);
6212 parmse
.expr
= null_pointer_node
;
6213 if (arg
->associated_dummy
6214 && gfc_dummy_arg_get_typespec (*arg
->associated_dummy
).type
6216 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
6218 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
6219 && e
->ts
.type
== BT_DERIVED
)
6221 /* The derived type needs to be converted to a temporary
6223 gfc_init_se (&parmse
, se
);
6224 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
6226 && e
->expr_type
== EXPR_VARIABLE
6227 && e
->symtree
->n
.sym
->attr
.optional
,
6228 CLASS_DATA (fsym
)->attr
.class_pointer
6229 || CLASS_DATA (fsym
)->attr
.allocatable
,
6232 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
6233 && e
->ts
.type
!= BT_PROCEDURE
6234 && (gfc_expr_attr (e
).flavor
!= FL_PROCEDURE
6235 || gfc_expr_attr (e
).proc
!= PROC_UNKNOWN
))
6237 /* The intrinsic type needs to be converted to a temporary
6238 CLASS object for the unlimited polymorphic formal. */
6239 gfc_find_vtab (&e
->ts
);
6240 gfc_init_se (&parmse
, se
);
6241 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
6244 else if (se
->ss
&& se
->ss
->info
->useflags
)
6250 /* An elemental function inside a scalarized loop. */
6251 gfc_init_se (&parmse
, se
);
6252 parm_kind
= ELEMENTAL
;
6254 /* When no fsym is present, ulim_copy is set and this is a third or
6255 fourth argument, use call-by-value instead of by reference to
6256 hand the length properties to the copy routine (i.e., most of the
6257 time this will be a call to a __copy_character_* routine where the
6258 third and fourth arguments are the lengths of a deferred length
6260 if ((fsym
&& fsym
->attr
.value
)
6261 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
6262 gfc_conv_expr (&parmse
, e
);
6264 gfc_conv_expr_reference (&parmse
, e
);
6266 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
6267 && e
->expr_type
== EXPR_FUNCTION
)
6268 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
6271 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
6272 && gfc_is_class_container_ref (e
))
6274 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6276 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
6277 && e
->symtree
->n
.sym
->attr
.optional
)
6279 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6280 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
6281 TREE_TYPE (parmse
.expr
),
6283 fold_convert (TREE_TYPE (parmse
.expr
),
6284 null_pointer_node
));
6288 /* If we are passing an absent array as optional dummy to an
6289 elemental procedure, make sure that we pass NULL when the data
6290 pointer is NULL. We need this extra conditional because of
6291 scalarization which passes arrays elements to the procedure,
6292 ignoring the fact that the array can be absent/unallocated/... */
6293 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
6295 tree descriptor_data
;
6297 descriptor_data
= ss
->info
->data
.array
.data
;
6298 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6300 fold_convert (TREE_TYPE (descriptor_data
),
6301 null_pointer_node
));
6303 = fold_build3_loc (input_location
, COND_EXPR
,
6304 TREE_TYPE (parmse
.expr
),
6305 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
6306 fold_convert (TREE_TYPE (parmse
.expr
),
6311 /* The scalarizer does not repackage the reference to a class
6312 array - instead it returns a pointer to the data element. */
6313 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
6314 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
6315 fsym
->attr
.intent
!= INTENT_IN
6316 && (CLASS_DATA (fsym
)->attr
.class_pointer
6317 || CLASS_DATA (fsym
)->attr
.allocatable
),
6319 && e
->expr_type
== EXPR_VARIABLE
6320 && e
->symtree
->n
.sym
->attr
.optional
,
6321 CLASS_DATA (fsym
)->attr
.class_pointer
6322 || CLASS_DATA (fsym
)->attr
.allocatable
);
6329 gfc_init_se (&parmse
, NULL
);
6331 /* Check whether the expression is a scalar or not; we cannot use
6332 e->rank as it can be nonzero for functions arguments. */
6333 argss
= gfc_walk_expr (e
);
6334 scalar
= argss
== gfc_ss_terminator
;
6336 gfc_free_ss_chain (argss
);
6338 /* Special handling for passing scalar polymorphic coarrays;
6339 otherwise one passes "class->_data.data" instead of "&class". */
6340 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
6341 && fsym
&& fsym
->ts
.type
== BT_CLASS
6342 && CLASS_DATA (fsym
)->attr
.codimension
6343 && !CLASS_DATA (fsym
)->attr
.dimension
)
6345 gfc_add_class_array_ref (e
);
6346 parmse
.want_coarray
= 1;
6350 /* A scalar or transformational function. */
6353 if (e
->expr_type
== EXPR_VARIABLE
6354 && e
->symtree
->n
.sym
->attr
.cray_pointee
6355 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
6357 /* The Cray pointer needs to be converted to a pointer to
6358 a type given by the expression. */
6359 gfc_conv_expr (&parmse
, e
);
6360 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
6361 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
6362 parmse
.expr
= convert (type
, tmp
);
6365 else if (sym
->attr
.is_bind_c
&& e
&& is_CFI_desc (fsym
, NULL
))
6366 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6367 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6369 else if (fsym
&& fsym
->attr
.value
)
6371 if (fsym
->ts
.type
== BT_CHARACTER
6372 && fsym
->ts
.is_c_interop
6373 && fsym
->ns
->proc_name
!= NULL
6374 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
6377 conv_scalar_char_value (fsym
, &parmse
, &e
);
6378 if (parmse
.expr
== NULL
)
6379 gfc_conv_expr (&parmse
, e
);
6383 gfc_conv_expr (&parmse
, e
);
6384 if (fsym
->attr
.optional
6385 && fsym
->ts
.type
!= BT_CLASS
6386 && fsym
->ts
.type
!= BT_DERIVED
)
6388 if (e
->expr_type
!= EXPR_VARIABLE
6389 || !e
->symtree
->n
.sym
->attr
.optional
6391 vec_safe_push (optionalargs
, boolean_true_node
);
6394 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6395 if (!e
->symtree
->n
.sym
->attr
.value
)
6397 = fold_build3_loc (input_location
, COND_EXPR
,
6398 TREE_TYPE (parmse
.expr
),
6400 fold_convert (TREE_TYPE (parmse
.expr
),
6401 integer_zero_node
));
6403 vec_safe_push (optionalargs
,
6404 fold_convert (boolean_type_node
,
6411 else if (arg
->name
&& arg
->name
[0] == '%')
6412 /* Argument list functions %VAL, %LOC and %REF are signalled
6413 through arg->name. */
6414 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
6415 else if ((e
->expr_type
== EXPR_FUNCTION
)
6416 && ((e
->value
.function
.esym
6417 && e
->value
.function
.esym
->result
->attr
.pointer
)
6418 || (!e
->value
.function
.esym
6419 && e
->symtree
->n
.sym
->attr
.pointer
))
6420 && fsym
&& fsym
->attr
.target
)
6421 /* Make sure the function only gets called once. */
6422 gfc_conv_expr_reference (&parmse
, e
);
6423 else if (e
->expr_type
== EXPR_FUNCTION
6424 && e
->symtree
->n
.sym
->result
6425 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
6426 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
6428 /* Functions returning procedure pointers. */
6429 gfc_conv_expr (&parmse
, e
);
6430 if (fsym
&& fsym
->attr
.proc_pointer
)
6431 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6436 if (e
->ts
.type
== BT_CLASS
&& fsym
6437 && fsym
->ts
.type
== BT_CLASS
6438 && (!CLASS_DATA (fsym
)->as
6439 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
6440 && CLASS_DATA (e
)->attr
.codimension
)
6442 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
6443 gcc_assert (!CLASS_DATA (fsym
)->as
);
6444 gfc_add_class_array_ref (e
);
6445 parmse
.want_coarray
= 1;
6446 gfc_conv_expr_reference (&parmse
, e
);
6447 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
6449 && e
->expr_type
== EXPR_VARIABLE
);
6451 else if (e
->ts
.type
== BT_CLASS
&& fsym
6452 && fsym
->ts
.type
== BT_CLASS
6453 && !CLASS_DATA (fsym
)->as
6454 && !CLASS_DATA (e
)->as
6455 && strcmp (fsym
->ts
.u
.derived
->name
,
6456 e
->ts
.u
.derived
->name
))
6458 type
= gfc_typenode_for_spec (&fsym
->ts
);
6459 var
= gfc_create_var (type
, fsym
->name
);
6460 gfc_conv_expr (&parmse
, e
);
6461 if (fsym
->attr
.optional
6462 && e
->expr_type
== EXPR_VARIABLE
6463 && e
->symtree
->n
.sym
->attr
.optional
)
6467 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6468 cond
= fold_build2_loc (input_location
, NE_EXPR
,
6469 logical_type_node
, tmp
,
6470 fold_convert (TREE_TYPE (tmp
),
6471 null_pointer_node
));
6472 gfc_start_block (&block
);
6473 gfc_add_modify (&block
, var
,
6474 fold_build1_loc (input_location
,
6476 type
, parmse
.expr
));
6477 gfc_add_expr_to_block (&parmse
.pre
,
6478 fold_build3_loc (input_location
,
6479 COND_EXPR
, void_type_node
,
6480 cond
, gfc_finish_block (&block
),
6481 build_empty_stmt (input_location
)));
6482 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6483 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
6484 TREE_TYPE (parmse
.expr
),
6486 fold_convert (TREE_TYPE (parmse
.expr
),
6487 null_pointer_node
));
6491 /* Since the internal representation of unlimited
6492 polymorphic expressions includes an extra field
6493 that other class objects do not, a cast to the
6494 formal type does not work. */
6495 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
6499 /* Set the _data field. */
6500 tmp
= gfc_class_data_get (var
);
6501 efield
= fold_convert (TREE_TYPE (tmp
),
6502 gfc_class_data_get (parmse
.expr
));
6503 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6505 /* Set the _vptr field. */
6506 tmp
= gfc_class_vptr_get (var
);
6507 efield
= fold_convert (TREE_TYPE (tmp
),
6508 gfc_class_vptr_get (parmse
.expr
));
6509 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6511 /* Set the _len field. */
6512 tmp
= gfc_class_len_get (var
);
6513 gfc_add_modify (&parmse
.pre
, tmp
,
6514 build_int_cst (TREE_TYPE (tmp
), 0));
6518 tmp
= fold_build1_loc (input_location
,
6521 gfc_add_modify (&parmse
.pre
, var
, tmp
);
6524 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6529 gfc_conv_expr_reference (&parmse
, e
);
6531 gfc_symbol
*dsym
= fsym
;
6532 gfc_dummy_arg
*dummy
;
6534 /* Use associated dummy as fallback for formal
6535 argument if there is no explicit interface. */
6537 && (dummy
= arg
->associated_dummy
)
6538 && dummy
->intrinsicness
== GFC_NON_INTRINSIC_DUMMY_ARG
6539 && dummy
->u
.non_intrinsic
->sym
)
6540 dsym
= dummy
->u
.non_intrinsic
->sym
;
6543 && dsym
->attr
.intent
== INTENT_OUT
6544 && !dsym
->attr
.allocatable
6545 && !dsym
->attr
.pointer
6546 && e
->expr_type
== EXPR_VARIABLE
6549 && e
->symtree
->n
.sym
6550 && !e
->symtree
->n
.sym
->attr
.dimension
6551 && e
->ts
.type
!= BT_CHARACTER
6552 && e
->ts
.type
!= BT_CLASS
6553 && (e
->ts
.type
!= BT_DERIVED
6554 || (dsym
->ts
.type
== BT_DERIVED
6555 && e
->ts
.u
.derived
== dsym
->ts
.u
.derived
6556 /* Types with allocatable components are
6557 excluded from clobbering because we need
6558 the unclobbered pointers to free the
6559 allocatable components in the callee.
6560 Same goes for finalizable types or types
6561 with finalizable components, we need to
6562 pass the unclobbered values to the
6563 finalization routines.
6564 For parameterized types, it's less clear
6565 but they may not have a constant size
6566 so better exclude them in any case. */
6567 && !e
->ts
.u
.derived
->attr
.alloc_comp
6568 && !e
->ts
.u
.derived
->attr
.pdt_type
6569 && !gfc_is_finalizable (e
->ts
.u
.derived
, NULL
)))
6570 && !sym
->attr
.elemental
)
6573 var
= build_fold_indirect_ref_loc (input_location
,
6575 tree clobber
= build_clobber (TREE_TYPE (var
));
6576 gfc_add_modify (&clobbers
, var
, clobber
);
6579 /* Catch base objects that are not variables. */
6580 if (e
->ts
.type
== BT_CLASS
6581 && e
->expr_type
!= EXPR_VARIABLE
6582 && expr
&& e
== expr
->base_expr
)
6583 base_object
= build_fold_indirect_ref_loc (input_location
,
6586 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6587 allocated on entry, it must be deallocated. */
6588 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
6589 && (fsym
->attr
.allocatable
6590 || (fsym
->ts
.type
== BT_CLASS
6591 && CLASS_DATA (fsym
)->attr
.allocatable
))
6592 && !is_CFI_desc (fsym
, NULL
))
6597 gfc_init_block (&block
);
6599 if (e
->ts
.type
== BT_CLASS
)
6600 ptr
= gfc_class_data_get (ptr
);
6602 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
6605 gfc_add_expr_to_block (&block
, tmp
);
6606 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6607 void_type_node
, ptr
,
6609 gfc_add_expr_to_block (&block
, tmp
);
6611 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
6613 gfc_add_modify (&block
, ptr
,
6614 fold_convert (TREE_TYPE (ptr
),
6615 null_pointer_node
));
6616 gfc_add_expr_to_block (&block
, tmp
);
6618 else if (fsym
->ts
.type
== BT_CLASS
)
6621 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
6622 tmp
= gfc_get_symbol_decl (vtab
);
6623 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6624 ptr
= gfc_class_vptr_get (parmse
.expr
);
6625 gfc_add_modify (&block
, ptr
,
6626 fold_convert (TREE_TYPE (ptr
), tmp
));
6627 gfc_add_expr_to_block (&block
, tmp
);
6630 if (fsym
->attr
.optional
6631 && e
->expr_type
== EXPR_VARIABLE
6632 && e
->symtree
->n
.sym
->attr
.optional
)
6634 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6636 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6637 gfc_finish_block (&block
),
6638 build_empty_stmt (input_location
));
6641 tmp
= gfc_finish_block (&block
);
6643 gfc_add_expr_to_block (&se
->pre
, tmp
);
6646 /* A class array element needs converting back to be a
6647 class object, if the formal argument is a class object. */
6648 if (fsym
&& fsym
->ts
.type
== BT_CLASS
6649 && e
->ts
.type
== BT_CLASS
6650 && ((CLASS_DATA (fsym
)->as
6651 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
6652 || CLASS_DATA (e
)->attr
.dimension
))
6653 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6654 fsym
->attr
.intent
!= INTENT_IN
6655 && (CLASS_DATA (fsym
)->attr
.class_pointer
6656 || CLASS_DATA (fsym
)->attr
.allocatable
),
6658 && e
->expr_type
== EXPR_VARIABLE
6659 && e
->symtree
->n
.sym
->attr
.optional
,
6660 CLASS_DATA (fsym
)->attr
.class_pointer
6661 || CLASS_DATA (fsym
)->attr
.allocatable
);
6663 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
6664 || fsym
->ts
.type
== BT_ASSUMED
)
6665 && e
->ts
.type
== BT_CLASS
6666 && !CLASS_DATA (e
)->attr
.dimension
6667 && !CLASS_DATA (e
)->attr
.codimension
)
6669 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6670 /* The result is a class temporary, whose _data component
6671 must be freed to avoid a memory leak. */
6672 if (e
->expr_type
== EXPR_FUNCTION
6673 && CLASS_DATA (e
)->attr
.allocatable
)
6679 /* Borrow the function symbol to make a call to
6680 gfc_add_finalizer_call and then restore it. */
6681 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6682 e
->symtree
->n
.sym
->backend_decl
6683 = TREE_OPERAND (parmse
.expr
, 0);
6684 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6685 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6686 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6688 gfc_free_expr (var
);
6689 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6690 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6692 /* Then free the class _data. */
6693 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6694 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6697 tmp
= build3_v (COND_EXPR
, tmp
,
6698 gfc_call_free (parmse
.expr
),
6699 build_empty_stmt (input_location
));
6700 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6701 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6705 /* Wrap scalar variable in a descriptor. We need to convert
6706 the address of a pointer back to the pointer itself before,
6707 we can assign it to the data field. */
6709 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6710 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6713 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6714 tmp
= TREE_OPERAND (tmp
, 0);
6715 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6717 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6720 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6721 && ((fsym
->attr
.pointer
6722 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6723 || (fsym
->attr
.proc_pointer
6724 && !(e
->expr_type
== EXPR_VARIABLE
6725 && e
->symtree
->n
.sym
->attr
.dummy
))
6726 || (fsym
->attr
.proc_pointer
6727 && e
->expr_type
== EXPR_VARIABLE
6728 && gfc_is_proc_ptr_comp (e
))
6729 || (fsym
->attr
.allocatable
6730 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6732 /* Scalar pointer dummy args require an extra level of
6733 indirection. The null pointer already contains
6734 this level of indirection. */
6735 parm_kind
= SCALAR_POINTER
;
6736 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6740 else if (e
->ts
.type
== BT_CLASS
6741 && fsym
&& fsym
->ts
.type
== BT_CLASS
6742 && (CLASS_DATA (fsym
)->attr
.dimension
6743 || CLASS_DATA (fsym
)->attr
.codimension
))
6745 /* Pass a class array. */
6746 parmse
.use_offset
= 1;
6747 gfc_conv_expr_descriptor (&parmse
, e
);
6749 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6750 allocated on entry, it must be deallocated. */
6751 if (fsym
->attr
.intent
== INTENT_OUT
6752 && CLASS_DATA (fsym
)->attr
.allocatable
)
6757 gfc_init_block (&block
);
6759 ptr
= gfc_class_data_get (ptr
);
6761 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6762 NULL_TREE
, NULL_TREE
,
6764 GFC_CAF_COARRAY_NOCOARRAY
);
6765 gfc_add_expr_to_block (&block
, tmp
);
6766 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6767 void_type_node
, ptr
,
6769 gfc_add_expr_to_block (&block
, tmp
);
6770 gfc_reset_vptr (&block
, e
);
6772 if (fsym
->attr
.optional
6773 && e
->expr_type
== EXPR_VARIABLE
6775 || (e
->ref
->type
== REF_ARRAY
6776 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6777 && e
->symtree
->n
.sym
->attr
.optional
)
6779 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6781 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6782 gfc_finish_block (&block
),
6783 build_empty_stmt (input_location
));
6786 tmp
= gfc_finish_block (&block
);
6788 gfc_add_expr_to_block (&se
->pre
, tmp
);
6791 /* The conversion does not repackage the reference to a class
6792 array - _data descriptor. */
6793 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6794 fsym
->attr
.intent
!= INTENT_IN
6795 && (CLASS_DATA (fsym
)->attr
.class_pointer
6796 || CLASS_DATA (fsym
)->attr
.allocatable
),
6798 && e
->expr_type
== EXPR_VARIABLE
6799 && e
->symtree
->n
.sym
->attr
.optional
,
6800 CLASS_DATA (fsym
)->attr
.class_pointer
6801 || CLASS_DATA (fsym
)->attr
.allocatable
);
6805 /* If the argument is a function call that may not create
6806 a temporary for the result, we have to check that we
6807 can do it, i.e. that there is no alias between this
6808 argument and another one. */
6809 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6815 intent
= fsym
->attr
.intent
;
6817 intent
= INTENT_UNKNOWN
;
6819 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6821 parmse
.force_tmp
= 1;
6823 iarg
= e
->value
.function
.actual
->expr
;
6825 /* Temporary needed if aliasing due to host association. */
6826 if (sym
->attr
.contained
6828 && !sym
->attr
.implicit_pure
6829 && !sym
->attr
.use_assoc
6830 && iarg
->expr_type
== EXPR_VARIABLE
6831 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6832 parmse
.force_tmp
= 1;
6834 /* Ditto within module. */
6835 if (sym
->attr
.use_assoc
6837 && !sym
->attr
.implicit_pure
6838 && iarg
->expr_type
== EXPR_VARIABLE
6839 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6840 parmse
.force_tmp
= 1;
6843 /* Special case for assumed-rank arrays: when passing an
6844 argument to a nonallocatable/nonpointer dummy, the bounds have
6845 to be reset as otherwise a last-dim ubound of -1 is
6846 indistinguishable from an assumed-size array in the callee. */
6847 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6848 && fsym
->as
->type
== AS_ASSUMED_RANK
6850 && e
->expr_type
== EXPR_VARIABLE
6851 && ((fsym
->ts
.type
== BT_CLASS
6852 && !CLASS_DATA (fsym
)->attr
.class_pointer
6853 && !CLASS_DATA (fsym
)->attr
.allocatable
)
6854 || (fsym
->ts
.type
!= BT_CLASS
6855 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)))
6857 /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
6859 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
6861 if (ref
->u
.ar
.type
== AR_FULL
6862 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SIZE
)
6863 ref
->u
.ar
.type
= AR_SECTION
;
6866 if (sym
->attr
.is_bind_c
&& e
&& is_CFI_desc (fsym
, NULL
))
6867 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6868 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6870 else if (e
->expr_type
== EXPR_VARIABLE
6871 && is_subref_array (e
)
6872 && !(fsym
&& fsym
->attr
.pointer
))
6873 /* The actual argument is a component reference to an
6874 array of derived types. In this case, the argument
6875 is converted to a temporary, which is passed and then
6876 written back after the procedure call. */
6877 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6878 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6879 fsym
&& fsym
->attr
.pointer
);
6881 else if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->as
6882 && CLASS_DATA (e
)->as
->type
== AS_ASSUMED_SIZE
6883 && nodesc_arg
&& fsym
->ts
.type
== BT_DERIVED
)
6884 /* An assumed size class actual argument being passed to
6885 a 'no descriptor' formal argument just requires the
6886 data pointer to be passed. For class dummy arguments
6887 this is stored in the symbol backend decl.. */
6888 parmse
.expr
= e
->symtree
->n
.sym
->backend_decl
;
6890 else if (gfc_is_class_array_ref (e
, NULL
)
6891 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6892 /* The actual argument is a component reference to an
6893 array of derived types. In this case, the argument
6894 is converted to a temporary, which is passed and then
6895 written back after the procedure call.
6896 OOP-TODO: Insert code so that if the dynamic type is
6897 the same as the declared type, copy-in/copy-out does
6899 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6901 fsym
->attr
.pointer
);
6903 else if (gfc_is_class_array_function (e
)
6904 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6905 /* See previous comment. For function actual argument,
6906 the write out is not needed so the intent is set as
6909 e
->must_finalize
= 1;
6910 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6911 INTENT_IN
, fsym
->attr
.pointer
);
6913 else if (fsym
&& fsym
->attr
.contiguous
6914 && !gfc_is_simply_contiguous (e
, false, true)
6915 && gfc_expr_is_variable (e
))
6917 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6919 fsym
->attr
.pointer
);
6922 /* This is where we introduce a temporary to store the
6923 result of a non-lvalue array expression. */
6924 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6927 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6928 allocated on entry, it must be deallocated.
6929 CFI descriptors are handled elsewhere. */
6930 if (fsym
&& fsym
->attr
.allocatable
6931 && fsym
->attr
.intent
== INTENT_OUT
6932 && !is_CFI_desc (fsym
, NULL
))
6934 if (fsym
->ts
.type
== BT_DERIVED
6935 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6937 // deallocate the components first
6938 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6939 parmse
.expr
, e
->rank
);
6940 /* But check whether dummy argument is optional. */
6941 if (tmp
!= NULL_TREE
6942 && fsym
->attr
.optional
6943 && e
->expr_type
== EXPR_VARIABLE
6944 && e
->symtree
->n
.sym
->attr
.optional
)
6947 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6948 tmp
= build3_v (COND_EXPR
, present
, tmp
,
6949 build_empty_stmt (input_location
));
6951 if (tmp
!= NULL_TREE
)
6952 gfc_add_expr_to_block (&se
->pre
, tmp
);
6956 /* With bind(C), the actual argument is replaced by a bind-C
6957 descriptor; in this case, the data component arrives here,
6958 which shall not be dereferenced, but still freed and
6960 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6961 tmp
= build_fold_indirect_ref_loc (input_location
,
6963 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6964 tmp
= gfc_conv_descriptor_data_get (tmp
);
6965 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6966 NULL_TREE
, NULL_TREE
, true,
6968 GFC_CAF_COARRAY_NOCOARRAY
);
6969 if (fsym
->attr
.optional
6970 && e
->expr_type
== EXPR_VARIABLE
6971 && e
->symtree
->n
.sym
->attr
.optional
)
6972 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6974 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6975 tmp
, build_empty_stmt (input_location
));
6976 gfc_add_expr_to_block (&se
->pre
, tmp
);
6980 /* Special case for an assumed-rank dummy argument. */
6981 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& e
->rank
> 0
6982 && (fsym
->ts
.type
== BT_CLASS
6983 ? (CLASS_DATA (fsym
)->as
6984 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
6985 : (fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
)))
6987 if (fsym
->ts
.type
== BT_CLASS
6988 ? (CLASS_DATA (fsym
)->attr
.class_pointer
6989 || CLASS_DATA (fsym
)->attr
.allocatable
)
6990 : (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
))
6992 /* Unallocated allocatable arrays and unassociated pointer
6993 arrays need their dtype setting if they are argument
6994 associated with assumed rank dummies to set the rank. */
6995 set_dtype_for_unallocated (&parmse
, e
);
6997 else if (e
->expr_type
== EXPR_VARIABLE
6998 && e
->symtree
->n
.sym
->attr
.dummy
6999 && (e
->ts
.type
== BT_CLASS
7000 ? (e
->ref
&& e
->ref
->next
7001 && e
->ref
->next
->type
== REF_ARRAY
7002 && e
->ref
->next
->u
.ar
.type
== AR_FULL
7003 && e
->ref
->next
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
7004 : (e
->ref
&& e
->ref
->type
== REF_ARRAY
7005 && e
->ref
->u
.ar
.type
== AR_FULL
7006 && e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)))
7008 /* Assumed-size actual to assumed-rank dummy requires
7009 dim[rank-1].ubound = -1. */
7011 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
7012 if (fsym
->ts
.type
== BT_CLASS
)
7013 tmp
= gfc_class_data_get (tmp
);
7014 minus_one
= build_int_cst (gfc_array_index_type
, -1);
7015 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
7016 gfc_rank_cst
[e
->rank
- 1],
7021 /* The case with fsym->attr.optional is that of a user subroutine
7022 with an interface indicating an optional argument. When we call
7023 an intrinsic subroutine, however, fsym is NULL, but we might still
7024 have an optional argument, so we proceed to the substitution
7026 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
7028 /* If an optional argument is itself an optional dummy argument,
7029 check its presence and substitute a null if absent. This is
7030 only needed when passing an array to an elemental procedure
7031 as then array elements are accessed - or no NULL pointer is
7032 allowed and a "1" or "0" should be passed if not present.
7033 When passing a non-array-descriptor full array to a
7034 non-array-descriptor dummy, no check is needed. For
7035 array-descriptor actual to array-descriptor dummy, see
7036 PR 41911 for why a check has to be inserted.
7037 fsym == NULL is checked as intrinsics required the descriptor
7038 but do not always set fsym.
7039 Also, it is necessary to pass a NULL pointer to library routines
7040 which usually ignore optional arguments, so they can handle
7041 these themselves. */
7042 if (e
->expr_type
== EXPR_VARIABLE
7043 && e
->symtree
->n
.sym
->attr
.optional
7044 && (((e
->rank
!= 0 && elemental_proc
)
7045 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
7049 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
7050 || fsym
->as
->type
== AS_ASSUMED_RANK
7051 || fsym
->as
->type
== AS_DEFERRED
)))))
7052 || se
->ignore_optional
))
7053 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
7054 e
->representation
.length
);
7059 /* Obtain the character length of an assumed character length
7060 length procedure from the typespec. */
7061 if (fsym
->ts
.type
== BT_CHARACTER
7062 && parmse
.string_length
== NULL_TREE
7063 && e
->ts
.type
== BT_PROCEDURE
7064 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
7065 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
7066 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7068 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
7069 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
7073 if (fsym
&& need_interface_mapping
&& e
)
7074 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
7076 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
7077 gfc_add_block_to_block (&post
, &parmse
.post
);
7078 gfc_add_block_to_block (&se
->finalblock
, &parmse
.finalblock
);
7080 /* Allocated allocatable components of derived types must be
7081 deallocated for non-variable scalars, array arguments to elemental
7082 procedures, and array arguments with descriptor to non-elemental
7083 procedures. As bounds information for descriptorless arrays is no
7084 longer available here, they are dealt with in trans-array.cc
7085 (gfc_conv_array_parameter). */
7086 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
7087 && e
->ts
.u
.derived
->attr
.alloc_comp
7088 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
7089 && !expr_may_alias_variables (e
, elemental_proc
))
7092 /* It is known the e returns a structure type with at least one
7093 allocatable component. When e is a function, ensure that the
7094 function is called once only by using a temporary variable. */
7095 if (!DECL_P (parmse
.expr
))
7096 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
7097 parmse
.expr
, &se
->pre
);
7099 if (fsym
&& fsym
->attr
.value
)
7102 tmp
= build_fold_indirect_ref_loc (input_location
,
7105 parm_rank
= e
->rank
;
7113 case (SCALAR_POINTER
):
7114 tmp
= build_fold_indirect_ref_loc (input_location
,
7119 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
7121 /* The derived type is passed to gfc_deallocate_alloc_comp.
7122 Therefore, class actuals can be handled correctly but derived
7123 types passed to class formals need the _data component. */
7124 tmp
= gfc_class_data_get (tmp
);
7125 if (!CLASS_DATA (fsym
)->attr
.dimension
)
7126 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7129 if (e
->expr_type
== EXPR_OP
7130 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
7131 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
7134 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
7135 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
7137 gfc_add_expr_to_block (&se
->post
, local_tmp
);
7140 if (!finalized
&& !e
->must_finalize
)
7142 bool scalar_res_outside_loop
;
7143 scalar_res_outside_loop
= e
->expr_type
== EXPR_FUNCTION
7147 /* Scalars passed to an assumed rank argument are converted to
7148 a descriptor. Obtain the data field before deallocating any
7149 allocatable components. */
7150 if (parm_rank
== 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
7151 tmp
= gfc_conv_descriptor_data_get (tmp
);
7153 if (scalar_res_outside_loop
)
7155 /* Go through the ss chain to find the argument and use
7156 the stored value. */
7157 gfc_ss
*tmp_ss
= parmse
.loop
->ss
;
7158 for (; tmp_ss
; tmp_ss
= tmp_ss
->next
)
7160 && tmp_ss
->info
->expr
== e
7161 && tmp_ss
->info
->data
.scalar
.value
!= NULL_TREE
)
7163 tmp
= tmp_ss
->info
->data
.scalar
.value
;
7170 if (derived_array
!= NULL_TREE
)
7171 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
,
7174 else if ((e
->ts
.type
== BT_CLASS
7175 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7176 || e
->ts
.type
== BT_DERIVED
)
7177 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
7179 else if (e
->ts
.type
== BT_CLASS
)
7180 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
7183 if (scalar_res_outside_loop
)
7184 gfc_add_expr_to_block (&parmse
.loop
->post
, tmp
);
7186 gfc_prepend_expr_to_block (&post
, tmp
);
7190 /* Add argument checking of passing an unallocated/NULL actual to
7191 a nonallocatable/nonpointer dummy. */
7193 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
7195 symbol_attribute attr
;
7199 symbol_attribute fsym_attr
;
7203 if (fsym
->ts
.type
== BT_CLASS
)
7205 fsym_attr
= CLASS_DATA (fsym
)->attr
;
7206 fsym_attr
.pointer
= fsym_attr
.class_pointer
;
7209 fsym_attr
= fsym
->attr
;
7212 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
7213 attr
= gfc_expr_attr (e
);
7215 goto end_pointer_check
;
7217 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
7218 allocatable to an optional dummy, cf. 12.5.2.12. */
7219 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
7220 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
7221 goto end_pointer_check
;
7225 /* If the actual argument is an optional pointer/allocatable and
7226 the formal argument takes an nonpointer optional value,
7227 it is invalid to pass a non-present argument on, even
7228 though there is no technical reason for this in gfortran.
7229 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
7230 tree present
, null_ptr
, type
;
7232 if (attr
.allocatable
7233 && (fsym
== NULL
|| !fsym_attr
.allocatable
))
7234 msg
= xasprintf ("Allocatable actual argument '%s' is not "
7235 "allocated or not present",
7236 e
->symtree
->n
.sym
->name
);
7237 else if (attr
.pointer
7238 && (fsym
== NULL
|| !fsym_attr
.pointer
))
7239 msg
= xasprintf ("Pointer actual argument '%s' is not "
7240 "associated or not present",
7241 e
->symtree
->n
.sym
->name
);
7242 else if (attr
.proc_pointer
&& !e
->value
.function
.actual
7243 && (fsym
== NULL
|| !fsym_attr
.proc_pointer
))
7244 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
7245 "associated or not present",
7246 e
->symtree
->n
.sym
->name
);
7248 goto end_pointer_check
;
7250 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
7251 type
= TREE_TYPE (present
);
7252 present
= fold_build2_loc (input_location
, EQ_EXPR
,
7253 logical_type_node
, present
,
7255 null_pointer_node
));
7256 type
= TREE_TYPE (parmse
.expr
);
7257 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
7258 logical_type_node
, parmse
.expr
,
7260 null_pointer_node
));
7261 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
7262 logical_type_node
, present
, null_ptr
);
7266 if (attr
.allocatable
7267 && (fsym
== NULL
|| !fsym_attr
.allocatable
))
7268 msg
= xasprintf ("Allocatable actual argument '%s' is not "
7269 "allocated", e
->symtree
->n
.sym
->name
);
7270 else if (attr
.pointer
7271 && (fsym
== NULL
|| !fsym_attr
.pointer
))
7272 msg
= xasprintf ("Pointer actual argument '%s' is not "
7273 "associated", e
->symtree
->n
.sym
->name
);
7274 else if (attr
.proc_pointer
&& !e
->value
.function
.actual
7275 && (fsym
== NULL
|| !fsym_attr
.proc_pointer
))
7276 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
7277 "associated", e
->symtree
->n
.sym
->name
);
7279 goto end_pointer_check
;
7282 if (fsym
&& fsym
->ts
.type
== BT_CLASS
)
7284 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
7285 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7286 tmp
= gfc_class_data_get (tmp
);
7287 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
7288 tmp
= gfc_conv_descriptor_data_get (tmp
);
7291 /* If the argument is passed by value, we need to strip the
7293 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
7294 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7296 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7297 logical_type_node
, tmp
,
7298 fold_convert (TREE_TYPE (tmp
),
7299 null_pointer_node
));
7302 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
7308 /* Deferred length dummies pass the character length by reference
7309 so that the value can be returned. */
7310 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
7312 if (INDIRECT_REF_P (parmse
.string_length
))
7313 /* In chains of functions/procedure calls the string_length already
7314 is a pointer to the variable holding the length. Therefore
7315 remove the deref on call. */
7316 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
7319 tmp
= parmse
.string_length
;
7320 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
7321 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
7322 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7326 /* Character strings are passed as two parameters, a length and a
7327 pointer - except for Bind(c) which only passes the pointer.
7328 An unlimited polymorphic formal argument likewise does not
7330 if (parmse
.string_length
!= NULL_TREE
7331 && !sym
->attr
.is_bind_c
7332 && !(fsym
&& UNLIMITED_POLY (fsym
)))
7333 vec_safe_push (stringargs
, parmse
.string_length
);
7335 /* When calling __copy for character expressions to unlimited
7336 polymorphic entities, the dst argument needs a string length. */
7337 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
7338 && startswith (sym
->name
, "__vtab_CHARACTER")
7339 && arg
->next
&& arg
->next
->expr
7340 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
7341 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
7342 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
7343 vec_safe_push (stringargs
, parmse
.string_length
);
7345 /* For descriptorless coarrays and assumed-shape coarray dummies, we
7346 pass the token and the offset as additional arguments. */
7347 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
7348 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
7349 && !fsym
->attr
.allocatable
)
7350 || (fsym
->ts
.type
== BT_CLASS
7351 && CLASS_DATA (fsym
)->attr
.codimension
7352 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
7354 /* Token and offset. */
7355 vec_safe_push (stringargs
, null_pointer_node
);
7356 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
7357 gcc_assert (fsym
->attr
.optional
);
7359 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
7360 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
7361 && !fsym
->attr
.allocatable
)
7362 || (fsym
->ts
.type
== BT_CLASS
7363 && CLASS_DATA (fsym
)->attr
.codimension
7364 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
7366 tree caf_decl
, caf_type
;
7369 caf_decl
= gfc_get_tree_for_caf_expr (e
);
7370 caf_type
= TREE_TYPE (caf_decl
);
7372 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
7373 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
7374 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
7375 tmp
= gfc_conv_descriptor_token (caf_decl
);
7376 else if (DECL_LANG_SPECIFIC (caf_decl
)
7377 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
7378 tmp
= GFC_DECL_TOKEN (caf_decl
);
7381 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
7382 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
7383 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
7386 vec_safe_push (stringargs
, tmp
);
7388 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
7389 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
7390 offset
= build_int_cst (gfc_array_index_type
, 0);
7391 else if (DECL_LANG_SPECIFIC (caf_decl
)
7392 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
7393 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
7394 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
7395 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
7397 offset
= build_int_cst (gfc_array_index_type
, 0);
7399 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
7400 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
7403 gcc_assert (POINTER_TYPE_P (caf_type
));
7407 tmp2
= fsym
->ts
.type
== BT_CLASS
7408 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
7409 if ((fsym
->ts
.type
!= BT_CLASS
7410 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
7411 || fsym
->as
->type
== AS_ASSUMED_RANK
))
7412 || (fsym
->ts
.type
== BT_CLASS
7413 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
7414 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
7416 if (fsym
->ts
.type
== BT_CLASS
)
7417 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7420 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7421 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
7423 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
7424 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7426 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7427 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7430 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7433 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7434 gfc_array_index_type
,
7435 fold_convert (gfc_array_index_type
, tmp2
),
7436 fold_convert (gfc_array_index_type
, tmp
));
7437 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
7438 gfc_array_index_type
, offset
, tmp
);
7440 vec_safe_push (stringargs
, offset
);
7443 vec_safe_push (arglist
, parmse
.expr
);
7446 gfc_add_block_to_block (&se
->pre
, &clobbers
);
7447 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
7451 else if (sym
->ts
.type
== BT_CLASS
)
7452 ts
= CLASS_DATA (sym
)->ts
;
7456 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
7457 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
7458 else if (ts
.type
== BT_CHARACTER
)
7460 if (ts
.u
.cl
->length
== NULL
)
7462 /* Assumed character length results are not allowed by C418 of the 2003
7463 standard and are trapped in resolve.cc; except in the case of SPREAD
7464 (and other intrinsics?) and dummy functions. In the case of SPREAD,
7465 we take the character length of the first argument for the result.
7466 For dummies, we have to look through the formal argument list for
7467 this function and use the character length found there.*/
7469 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
7470 else if (!sym
->attr
.dummy
)
7471 cl
.backend_decl
= (*stringargs
)[0];
7474 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
7475 for (; formal
; formal
= formal
->next
)
7476 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
7477 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
7479 len
= cl
.backend_decl
;
7485 /* Calculate the length of the returned string. */
7486 gfc_init_se (&parmse
, NULL
);
7487 if (need_interface_mapping
)
7488 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
7490 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
7491 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
7492 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
7494 /* TODO: It would be better to have the charlens as
7495 gfc_charlen_type_node already when the interface is
7496 created instead of converting it here (see PR 84615). */
7497 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
7498 gfc_charlen_type_node
,
7499 fold_convert (gfc_charlen_type_node
, tmp
),
7500 build_zero_cst (gfc_charlen_type_node
));
7501 cl
.backend_decl
= tmp
;
7504 /* Set up a charlen structure for it. */
7509 len
= cl
.backend_decl
;
7512 byref
= (comp
&& (comp
->attr
.dimension
7513 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
7514 || (!comp
&& gfc_return_by_reference (sym
));
7517 if (se
->direct_byref
)
7519 /* Sometimes, too much indirection can be applied; e.g. for
7520 function_result = array_valued_recursive_function. */
7521 if (TREE_TYPE (TREE_TYPE (se
->expr
))
7522 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
7523 && GFC_DESCRIPTOR_TYPE_P
7524 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
7525 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7528 /* If the lhs of an assignment x = f(..) is allocatable and
7529 f2003 is allowed, we must do the automatic reallocation.
7530 TODO - deal with intrinsics, without using a temporary. */
7531 if (flag_realloc_lhs
7532 && se
->ss
&& se
->ss
->loop_chain
7533 && se
->ss
->loop_chain
->is_alloc_lhs
7534 && !expr
->value
.function
.isym
7535 && sym
->result
->as
!= NULL
)
7537 /* Evaluate the bounds of the result, if known. */
7538 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
7541 /* Perform the automatic reallocation. */
7542 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
7544 gfc_add_expr_to_block (&se
->pre
, tmp
);
7546 /* Pass the temporary as the first argument. */
7547 result
= info
->descriptor
;
7550 result
= build_fold_indirect_ref_loc (input_location
,
7552 vec_safe_push (retargs
, se
->expr
);
7554 else if (comp
&& comp
->attr
.dimension
)
7556 gcc_assert (se
->loop
&& info
);
7558 /* Set the type of the array. */
7559 tmp
= gfc_typenode_for_spec (&comp
->ts
);
7560 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
7562 /* Evaluate the bounds of the result, if known. */
7563 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
7565 /* If the lhs of an assignment x = f(..) is allocatable and
7566 f2003 is allowed, we must not generate the function call
7567 here but should just send back the results of the mapping.
7568 This is signalled by the function ss being flagged. */
7569 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
7571 gfc_free_interface_mapping (&mapping
);
7572 return has_alternate_specifier
;
7575 /* Create a temporary to store the result. In case the function
7576 returns a pointer, the temporary will be a shallow copy and
7577 mustn't be deallocated. */
7578 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
7579 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
7580 tmp
, NULL_TREE
, false,
7581 !comp
->attr
.pointer
, callee_alloc
,
7582 &se
->ss
->info
->expr
->where
);
7584 /* Pass the temporary as the first argument. */
7585 result
= info
->descriptor
;
7586 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7587 vec_safe_push (retargs
, tmp
);
7589 else if (!comp
&& sym
->result
->attr
.dimension
)
7591 gcc_assert (se
->loop
&& info
);
7593 /* Set the type of the array. */
7594 tmp
= gfc_typenode_for_spec (&ts
);
7595 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
7597 /* Evaluate the bounds of the result, if known. */
7598 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
7600 /* If the lhs of an assignment x = f(..) is allocatable and
7601 f2003 is allowed, we must not generate the function call
7602 here but should just send back the results of the mapping.
7603 This is signalled by the function ss being flagged. */
7604 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
7606 gfc_free_interface_mapping (&mapping
);
7607 return has_alternate_specifier
;
7610 /* Create a temporary to store the result. In case the function
7611 returns a pointer, the temporary will be a shallow copy and
7612 mustn't be deallocated. */
7613 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
7614 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
7615 tmp
, NULL_TREE
, false,
7616 !sym
->attr
.pointer
, callee_alloc
,
7617 &se
->ss
->info
->expr
->where
);
7619 /* Pass the temporary as the first argument. */
7620 result
= info
->descriptor
;
7621 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7622 vec_safe_push (retargs
, tmp
);
7624 else if (ts
.type
== BT_CHARACTER
)
7626 /* Pass the string length. */
7627 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
7628 type
= build_pointer_type (type
);
7630 /* Emit a DECL_EXPR for the VLA type. */
7631 tmp
= TREE_TYPE (type
);
7633 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
7635 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
7636 DECL_ARTIFICIAL (tmp
) = 1;
7637 DECL_IGNORED_P (tmp
) = 1;
7638 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
7639 TREE_TYPE (tmp
), tmp
);
7640 gfc_add_expr_to_block (&se
->pre
, tmp
);
7643 /* Return an address to a char[0:len-1]* temporary for
7644 character pointers. */
7645 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7646 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7648 var
= gfc_create_var (type
, "pstr");
7650 if ((!comp
&& sym
->attr
.allocatable
)
7651 || (comp
&& comp
->attr
.allocatable
))
7653 gfc_add_modify (&se
->pre
, var
,
7654 fold_convert (TREE_TYPE (var
),
7655 null_pointer_node
));
7656 tmp
= gfc_call_free (var
);
7657 gfc_add_expr_to_block (&se
->post
, tmp
);
7660 /* Provide an address expression for the function arguments. */
7661 var
= gfc_build_addr_expr (NULL_TREE
, var
);
7664 var
= gfc_conv_string_tmp (se
, type
, len
);
7666 vec_safe_push (retargs
, var
);
7670 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
7672 type
= gfc_get_complex_type (ts
.kind
);
7673 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
7674 vec_safe_push (retargs
, var
);
7677 /* Add the string length to the argument list. */
7678 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
7682 tmp
= gfc_evaluate_now (len
, &se
->pre
);
7683 TREE_STATIC (tmp
) = 1;
7684 gfc_add_modify (&se
->pre
, tmp
,
7685 build_int_cst (TREE_TYPE (tmp
), 0));
7686 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7687 vec_safe_push (retargs
, tmp
);
7689 else if (ts
.type
== BT_CHARACTER
)
7690 vec_safe_push (retargs
, len
);
7692 gfc_free_interface_mapping (&mapping
);
7694 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7695 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
7696 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
7697 vec_safe_reserve (retargs
, arglen
);
7699 /* Add the return arguments. */
7700 vec_safe_splice (retargs
, arglist
);
7702 /* Add the hidden present status for optional+value to the arguments. */
7703 vec_safe_splice (retargs
, optionalargs
);
7705 /* Add the hidden string length parameters to the arguments. */
7706 vec_safe_splice (retargs
, stringargs
);
7708 /* We may want to append extra arguments here. This is used e.g. for
7709 calls to libgfortran_matmul_??, which need extra information. */
7710 vec_safe_splice (retargs
, append_args
);
7714 /* Generate the actual call. */
7715 if (base_object
== NULL_TREE
)
7716 conv_function_val (se
, sym
, expr
, args
);
7718 conv_base_obj_fcn_val (se
, base_object
, expr
);
7720 /* If there are alternate return labels, function type should be
7721 integer. Can't modify the type in place though, since it can be shared
7722 with other functions. For dummy arguments, the typing is done to
7723 this result, even if it has to be repeated for each call. */
7724 if (has_alternate_specifier
7725 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
7727 if (!sym
->attr
.dummy
)
7729 TREE_TYPE (sym
->backend_decl
)
7730 = build_function_type (integer_type_node
,
7731 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
7732 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
7735 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
7738 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
7739 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
7741 /* Allocatable scalar function results must be freed and nullified
7742 after use. This necessitates the creation of a temporary to
7743 hold the result to prevent duplicate calls. */
7744 symbol_attribute attr
= comp
? comp
->attr
: sym
->attr
;
7745 bool allocatable
= attr
.allocatable
&& !attr
.dimension
;
7746 gfc_symbol
*der
= comp
?
7747 comp
->ts
.type
== BT_DERIVED
? comp
->ts
.u
.derived
: NULL
7749 sym
->ts
.type
== BT_DERIVED
? sym
->ts
.u
.derived
: NULL
;
7750 bool finalizable
= der
!= NULL
&& der
->ns
->proc_name
7751 && gfc_is_finalizable (der
, NULL
);
7753 if (!byref
&& finalizable
)
7754 gfc_finalize_tree_expr (se
, der
, attr
, expr
->rank
);
7756 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
7757 && allocatable
&& !finalizable
)
7759 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7760 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
7762 tmp
= gfc_call_free (tmp
);
7763 gfc_add_expr_to_block (&post
, tmp
);
7764 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
7767 /* If we have a pointer function, but we don't want a pointer, e.g.
7770 where f is pointer valued, we have to dereference the result. */
7771 if (!se
->want_pointer
&& !byref
7772 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7773 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
7774 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7776 /* f2c calling conventions require a scalar default real function to
7777 return a double precision result. Convert this back to default
7778 real. We only care about the cases that can happen in Fortran 77.
7780 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
7781 && sym
->ts
.kind
== gfc_default_real_kind
7782 && !sym
->attr
.always_explicit
)
7783 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
7785 /* A pure function may still have side-effects - it may modify its
7787 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7789 if (!sym
->attr
.pure
)
7790 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7795 /* Add the function call to the pre chain. There is no expression. */
7796 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
7797 se
->expr
= NULL_TREE
;
7799 if (!se
->direct_byref
)
7801 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
7803 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
7805 /* Check the data pointer hasn't been modified. This would
7806 happen in a function returning a pointer. */
7807 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7808 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7811 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7814 se
->expr
= info
->descriptor
;
7815 /* Bundle in the string length. */
7816 se
->string_length
= len
;
7819 gfc_finalize_tree_expr (se
, der
, attr
, expr
->rank
);
7821 else if (ts
.type
== BT_CHARACTER
)
7823 /* Dereference for character pointer results. */
7824 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7825 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7826 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7830 se
->string_length
= len
;
7834 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7835 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7840 /* Associate the rhs class object's meta-data with the result, when the
7841 result is a temporary. */
7842 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7843 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7844 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7847 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7849 gfc_init_se (&parmse
, NULL
);
7850 parmse
.data_not_needed
= 1;
7851 gfc_conv_expr (&parmse
, class_expr
);
7852 if (!DECL_LANG_SPECIFIC (result
))
7853 gfc_allocate_lang_decl (result
);
7854 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7855 gfc_free_expr (class_expr
);
7856 /* -fcheck= can add diagnostic code, which has to be placed before
7858 if (parmse
.pre
.head
!= NULL
)
7859 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7860 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7863 /* Follow the function call with the argument post block. */
7866 gfc_add_block_to_block (&se
->pre
, &post
);
7868 /* Transformational functions of derived types with allocatable
7869 components must have the result allocatable components copied when the
7870 argument is actually given. */
7871 arg
= expr
->value
.function
.actual
;
7872 if (result
&& arg
&& expr
->rank
7873 && expr
->value
.function
.isym
7874 && expr
->value
.function
.isym
->transformational
7876 && arg
->expr
->ts
.type
== BT_DERIVED
7877 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7880 /* Copy the allocatable components. We have to use a
7881 temporary here to prevent source allocatable components
7882 from being corrupted. */
7883 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7884 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7885 result
, tmp2
, expr
->rank
, 0);
7886 gfc_add_expr_to_block (&se
->pre
, tmp
);
7887 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7889 gfc_add_expr_to_block (&se
->pre
, tmp
);
7891 /* Finally free the temporary's data field. */
7892 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7893 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7894 NULL_TREE
, NULL_TREE
, true,
7895 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7896 gfc_add_expr_to_block (&se
->pre
, tmp
);
7901 /* For a function with a class array result, save the result as
7902 a temporary, set the info fields needed by the scalarizer and
7903 call the finalization function of the temporary. Note that the
7904 nullification of allocatable components needed by the result
7905 is done in gfc_trans_assignment_1. */
7906 if (expr
&& ((gfc_is_class_array_function (expr
)
7907 && se
->ss
&& se
->ss
->loop
)
7908 || gfc_is_alloc_class_scalar_function (expr
))
7909 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7910 && expr
->must_finalize
)
7913 if (se
->ss
&& se
->ss
->loop
)
7915 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7916 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7917 tmp
= gfc_class_data_get (se
->expr
);
7918 info
->descriptor
= tmp
;
7919 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7920 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7921 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7923 tree dim
= gfc_rank_cst
[n
];
7924 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7925 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7930 /* TODO Eliminate the doubling of temporaries. This
7931 one is necessary to ensure no memory leakage. */
7932 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7935 /* Finalize the result, if necessary. */
7936 attr
= CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
;
7937 if (!((gfc_is_class_array_function (expr
)
7938 || gfc_is_alloc_class_scalar_function (expr
))
7940 gfc_finalize_tree_expr (se
, NULL
, attr
, expr
->rank
);
7942 gfc_add_block_to_block (&se
->post
, &post
);
7945 return has_alternate_specifier
;
7949 /* Fill a character string with spaces. */
7952 fill_with_spaces (tree start
, tree type
, tree size
)
7954 stmtblock_t block
, loop
;
7955 tree i
, el
, exit_label
, cond
, tmp
;
7957 /* For a simple char type, we can call memset(). */
7958 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7959 return build_call_expr_loc (input_location
,
7960 builtin_decl_explicit (BUILT_IN_MEMSET
),
7962 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7963 lang_hooks
.to_target_charset (' ')),
7964 fold_convert (size_type_node
, size
));
7966 /* Otherwise, we use a loop:
7967 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7971 /* Initialize variables. */
7972 gfc_init_block (&block
);
7973 i
= gfc_create_var (sizetype
, "i");
7974 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7975 el
= gfc_create_var (build_pointer_type (type
), "el");
7976 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7977 exit_label
= gfc_build_label_decl (NULL_TREE
);
7978 TREE_USED (exit_label
) = 1;
7982 gfc_init_block (&loop
);
7984 /* Exit condition. */
7985 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7986 build_zero_cst (sizetype
));
7987 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7988 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7989 build_empty_stmt (input_location
));
7990 gfc_add_expr_to_block (&loop
, tmp
);
7993 gfc_add_modify (&loop
,
7994 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7995 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7997 /* Increment loop variables. */
7998 gfc_add_modify (&loop
, i
,
7999 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
8000 TYPE_SIZE_UNIT (type
)));
8001 gfc_add_modify (&loop
, el
,
8002 fold_build_pointer_plus_loc (input_location
,
8003 el
, TYPE_SIZE_UNIT (type
)));
8005 /* Making the loop... actually loop! */
8006 tmp
= gfc_finish_block (&loop
);
8007 tmp
= build1_v (LOOP_EXPR
, tmp
);
8008 gfc_add_expr_to_block (&block
, tmp
);
8010 /* The exit label. */
8011 tmp
= build1_v (LABEL_EXPR
, exit_label
);
8012 gfc_add_expr_to_block (&block
, tmp
);
8015 return gfc_finish_block (&block
);
8019 /* Generate code to copy a string. */
8022 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
8023 int dkind
, tree slength
, tree src
, int skind
)
8025 tree tmp
, dlen
, slen
;
8034 stmtblock_t tempblock
;
8036 gcc_assert (dkind
== skind
);
8038 if (slength
!= NULL_TREE
)
8040 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
8041 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
8045 slen
= build_one_cst (gfc_charlen_type_node
);
8049 if (dlength
!= NULL_TREE
)
8051 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
8052 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
8056 dlen
= build_one_cst (gfc_charlen_type_node
);
8060 /* Assign directly if the types are compatible. */
8061 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
8062 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
8064 gfc_add_modify (block
, dsc
, ssc
);
8068 /* The string copy algorithm below generates code like
8072 if (srclen < destlen)
8074 memmove (dest, src, srclen);
8076 memset (&dest[srclen], ' ', destlen - srclen);
8080 // Truncate if too long.
8081 memmove (dest, src, destlen);
8086 /* Do nothing if the destination length is zero. */
8087 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
8088 build_zero_cst (TREE_TYPE (dlen
)));
8090 /* For non-default character kinds, we have to multiply the string
8091 length by the base type size. */
8092 chartype
= gfc_get_char_type (dkind
);
8093 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
8095 fold_convert (TREE_TYPE (slen
),
8096 TYPE_SIZE_UNIT (chartype
)));
8097 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
8099 fold_convert (TREE_TYPE (dlen
),
8100 TYPE_SIZE_UNIT (chartype
)));
8102 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
8103 dest
= fold_convert (pvoid_type_node
, dest
);
8105 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
8107 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
8108 src
= fold_convert (pvoid_type_node
, src
);
8110 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8112 /* Truncate string if source is too long. */
8113 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
8116 /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
8117 if (!CONSTANT_CLASS_P (cond2
))
8119 dest
= gfc_evaluate_now (dest
, block
);
8120 src
= gfc_evaluate_now (src
, block
);
8123 /* Copy and pad with spaces. */
8124 tmp3
= build_call_expr_loc (input_location
,
8125 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8127 fold_convert (size_type_node
, slen
));
8129 /* Wstringop-overflow appears at -O3 even though this warning is not
8130 explicitly available in fortran nor can it be switched off. If the
8131 source length is a constant, its negative appears as a very large
8132 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
8133 the result of the MINUS_EXPR suppresses this spurious warning. */
8134 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8135 TREE_TYPE(dlen
), dlen
, slen
);
8136 if (slength
&& TREE_CONSTANT (slength
))
8137 tmp
= gfc_evaluate_now (tmp
, block
);
8139 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
8140 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
8142 gfc_init_block (&tempblock
);
8143 gfc_add_expr_to_block (&tempblock
, tmp3
);
8144 gfc_add_expr_to_block (&tempblock
, tmp4
);
8145 tmp3
= gfc_finish_block (&tempblock
);
8147 /* The truncated memmove if the slen >= dlen. */
8148 tmp2
= build_call_expr_loc (input_location
,
8149 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8151 fold_convert (size_type_node
, dlen
));
8153 /* The whole copy_string function is there. */
8154 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
8156 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8157 build_empty_stmt (input_location
));
8158 gfc_add_expr_to_block (block
, tmp
);
8162 /* Translate a statement function.
8163 The value of a statement function reference is obtained by evaluating the
8164 expression using the values of the actual arguments for the values of the
8165 corresponding dummy arguments. */
8168 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
8172 gfc_formal_arglist
*fargs
;
8173 gfc_actual_arglist
*args
;
8176 gfc_saved_var
*saved_vars
;
8182 sym
= expr
->symtree
->n
.sym
;
8183 args
= expr
->value
.function
.actual
;
8184 gfc_init_se (&lse
, NULL
);
8185 gfc_init_se (&rse
, NULL
);
8188 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
8190 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
8191 temp_vars
= XCNEWVEC (tree
, n
);
8193 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8194 fargs
= fargs
->next
, n
++)
8196 /* Each dummy shall be specified, explicitly or implicitly, to be
8198 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
8201 if (fsym
->ts
.type
== BT_CHARACTER
)
8203 /* Copy string arguments. */
8206 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
8207 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
8209 /* Create a temporary to hold the value. */
8210 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
8211 fsym
->ts
.u
.cl
->backend_decl
8212 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
8214 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
8215 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
8217 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8219 gfc_conv_expr (&rse
, args
->expr
);
8220 gfc_conv_string_parameter (&rse
);
8221 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
8222 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
8224 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
8225 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
8226 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
8227 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
8231 /* For everything else, just evaluate the expression. */
8233 /* Create a temporary to hold the value. */
8234 type
= gfc_typenode_for_spec (&fsym
->ts
);
8235 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
8237 gfc_conv_expr (&lse
, args
->expr
);
8239 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
8240 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
8241 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
8247 /* Use the temporary variables in place of the real ones. */
8248 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8249 fargs
= fargs
->next
, n
++)
8250 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
8252 gfc_conv_expr (se
, sym
->value
);
8254 if (sym
->ts
.type
== BT_CHARACTER
)
8256 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
8258 /* Force the expression to the correct length. */
8259 if (!INTEGER_CST_P (se
->string_length
)
8260 || tree_int_cst_lt (se
->string_length
,
8261 sym
->ts
.u
.cl
->backend_decl
))
8263 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
8264 tmp
= gfc_create_var (type
, sym
->name
);
8265 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
8266 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
8267 sym
->ts
.kind
, se
->string_length
, se
->expr
,
8271 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
8274 /* Restore the original variables. */
8275 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8276 fargs
= fargs
->next
, n
++)
8277 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
8283 /* Translate a function expression. */
8286 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
8290 if (expr
->value
.function
.isym
)
8292 gfc_conv_intrinsic_function (se
, expr
);
8296 /* expr.value.function.esym is the resolved (specific) function symbol for
8297 most functions. However this isn't set for dummy procedures. */
8298 sym
= expr
->value
.function
.esym
;
8300 sym
= expr
->symtree
->n
.sym
;
8302 /* The IEEE_ARITHMETIC functions are caught here. */
8303 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
8304 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
8307 /* We distinguish statement functions from general functions to improve
8308 runtime performance. */
8309 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
8311 gfc_conv_statement_function (se
, expr
);
8315 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
8320 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
8323 is_zero_initializer_p (gfc_expr
* expr
)
8325 if (expr
->expr_type
!= EXPR_CONSTANT
)
8328 /* We ignore constants with prescribed memory representations for now. */
8329 if (expr
->representation
.string
)
8332 switch (expr
->ts
.type
)
8335 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
8338 return mpfr_zero_p (expr
->value
.real
)
8339 && MPFR_SIGN (expr
->value
.real
) >= 0;
8342 return expr
->value
.logical
== 0;
8345 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
8346 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
8347 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
8348 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
8358 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
8363 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
8364 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
8366 gfc_conv_tmp_array_ref (se
);
8370 /* Build a static initializer. EXPR is the expression for the initial value.
8371 The other parameters describe the variable of the component being
8372 initialized. EXPR may be null. */
8375 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
8376 bool array
, bool pointer
, bool procptr
)
8380 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
8381 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
8382 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
8383 return build_constructor (type
, NULL
);
8385 if (!(expr
|| pointer
|| procptr
))
8388 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
8389 (these are the only two iso_c_binding derived types that can be
8390 used as initialization expressions). If so, we need to modify
8391 the 'expr' to be that for a (void *). */
8392 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
8393 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
8395 if (TREE_CODE (type
) == ARRAY_TYPE
)
8396 return build_constructor (type
, NULL
);
8397 else if (POINTER_TYPE_P (type
))
8398 return build_int_cst (type
, 0);
8403 if (array
&& !procptr
)
8406 /* Arrays need special handling. */
8408 ctor
= gfc_build_null_descriptor (type
);
8409 /* Special case assigning an array to zero. */
8410 else if (is_zero_initializer_p (expr
))
8411 ctor
= build_constructor (type
, NULL
);
8413 ctor
= gfc_conv_array_initializer (type
, expr
);
8414 TREE_STATIC (ctor
) = 1;
8417 else if (pointer
|| procptr
)
8419 if (ts
->type
== BT_CLASS
&& !procptr
)
8421 gfc_init_se (&se
, NULL
);
8422 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
8423 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
8424 TREE_STATIC (se
.expr
) = 1;
8427 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
8428 return fold_convert (type
, null_pointer_node
);
8431 gfc_init_se (&se
, NULL
);
8432 se
.want_pointer
= 1;
8433 gfc_conv_expr (&se
, expr
);
8434 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
8444 gfc_init_se (&se
, NULL
);
8445 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8446 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
8448 gfc_conv_structure (&se
, expr
, 1);
8449 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
8450 TREE_STATIC (se
.expr
) = 1;
8454 if (expr
->expr_type
== EXPR_CONSTANT
)
8456 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
, expr
);
8457 TREE_STATIC (ctor
) = 1;
8463 gfc_init_se (&se
, NULL
);
8464 gfc_conv_constant (&se
, expr
);
8465 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
8472 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
8478 gfc_array_info
*lss_array
;
8485 gfc_start_block (&block
);
8487 /* Initialize the scalarizer. */
8488 gfc_init_loopinfo (&loop
);
8490 gfc_init_se (&lse
, NULL
);
8491 gfc_init_se (&rse
, NULL
);
8494 rss
= gfc_walk_expr (expr
);
8495 if (rss
== gfc_ss_terminator
)
8496 /* The rhs is scalar. Add a ss for the expression. */
8497 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
8499 /* Create a SS for the destination. */
8500 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
8502 lss_array
= &lss
->info
->data
.array
;
8503 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
8504 lss_array
->descriptor
= dest
;
8505 lss_array
->data
= gfc_conv_array_data (dest
);
8506 lss_array
->offset
= gfc_conv_array_offset (dest
);
8507 for (n
= 0; n
< cm
->as
->rank
; n
++)
8509 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
8510 lss_array
->stride
[n
] = gfc_index_one_node
;
8512 mpz_init (lss_array
->shape
[n
]);
8513 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
8514 cm
->as
->lower
[n
]->value
.integer
);
8515 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
8518 /* Associate the SS with the loop. */
8519 gfc_add_ss_to_loop (&loop
, lss
);
8520 gfc_add_ss_to_loop (&loop
, rss
);
8522 /* Calculate the bounds of the scalarization. */
8523 gfc_conv_ss_startstride (&loop
);
8525 /* Setup the scalarizing loops. */
8526 gfc_conv_loop_setup (&loop
, &expr
->where
);
8528 /* Setup the gfc_se structures. */
8529 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8530 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8533 gfc_mark_ss_chain_used (rss
, 1);
8535 gfc_mark_ss_chain_used (lss
, 1);
8537 /* Start the scalarized loop body. */
8538 gfc_start_scalarized_body (&loop
, &body
);
8540 gfc_conv_tmp_array_ref (&lse
);
8541 if (cm
->ts
.type
== BT_CHARACTER
)
8542 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8544 gfc_conv_expr (&rse
, expr
);
8546 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
8547 gfc_add_expr_to_block (&body
, tmp
);
8549 gcc_assert (rse
.ss
== gfc_ss_terminator
);
8551 /* Generate the copying loops. */
8552 gfc_trans_scalarizing_loops (&loop
, &body
);
8554 /* Wrap the whole thing up. */
8555 gfc_add_block_to_block (&block
, &loop
.pre
);
8556 gfc_add_block_to_block (&block
, &loop
.post
);
8558 gcc_assert (lss_array
->shape
!= NULL
);
8559 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
8560 gfc_cleanup_loop (&loop
);
8562 return gfc_finish_block (&block
);
8567 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
8577 gfc_expr
*arg
= NULL
;
8579 gfc_start_block (&block
);
8580 gfc_init_se (&se
, NULL
);
8582 /* Get the descriptor for the expressions. */
8583 se
.want_pointer
= 0;
8584 gfc_conv_expr_descriptor (&se
, expr
);
8585 gfc_add_block_to_block (&block
, &se
.pre
);
8586 gfc_add_modify (&block
, dest
, se
.expr
);
8588 /* Deal with arrays of derived types with allocatable components. */
8589 if (gfc_bt_struct (cm
->ts
.type
)
8590 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
8591 // TODO: Fix caf_mode
8592 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
8595 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
8596 && CLASS_DATA(cm
)->attr
.allocatable
)
8598 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
8599 // TODO: Fix caf_mode
8600 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
8605 tmp
= TREE_TYPE (dest
);
8606 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8607 tmp
, expr
->rank
, NULL_TREE
);
8611 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8612 TREE_TYPE(cm
->backend_decl
),
8613 cm
->as
->rank
, NULL_TREE
);
8615 gfc_add_expr_to_block (&block
, tmp
);
8616 gfc_add_block_to_block (&block
, &se
.post
);
8618 if (expr
->expr_type
!= EXPR_VARIABLE
)
8619 gfc_conv_descriptor_data_set (&block
, se
.expr
,
8622 /* We need to know if the argument of a conversion function is a
8623 variable, so that the correct lower bound can be used. */
8624 if (expr
->expr_type
== EXPR_FUNCTION
8625 && expr
->value
.function
.isym
8626 && expr
->value
.function
.isym
->conversion
8627 && expr
->value
.function
.actual
->expr
8628 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
8629 arg
= expr
->value
.function
.actual
->expr
;
8631 /* Obtain the array spec of full array references. */
8633 as
= gfc_get_full_arrayspec_from_expr (arg
);
8635 as
= gfc_get_full_arrayspec_from_expr (expr
);
8637 /* Shift the lbound and ubound of temporaries to being unity,
8638 rather than zero, based. Always calculate the offset. */
8639 offset
= gfc_conv_descriptor_offset_get (dest
);
8640 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8641 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
8643 for (n
= 0; n
< expr
->rank
; n
++)
8648 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8649 TODO It looks as if gfc_conv_expr_descriptor should return
8650 the correct bounds and that the following should not be
8651 necessary. This would simplify gfc_conv_intrinsic_bound
8653 if (as
&& as
->lower
[n
])
8656 gfc_init_se (&lbse
, NULL
);
8657 gfc_conv_expr (&lbse
, as
->lower
[n
]);
8658 gfc_add_block_to_block (&block
, &lbse
.pre
);
8659 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
8663 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
8664 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
8668 lbound
= gfc_conv_descriptor_lbound_get (dest
,
8671 lbound
= gfc_index_one_node
;
8673 lbound
= fold_convert (gfc_array_index_type
, lbound
);
8675 /* Shift the bounds and set the offset accordingly. */
8676 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
8677 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8678 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
8679 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8681 gfc_conv_descriptor_ubound_set (&block
, dest
,
8682 gfc_rank_cst
[n
], tmp
);
8683 gfc_conv_descriptor_lbound_set (&block
, dest
,
8684 gfc_rank_cst
[n
], lbound
);
8686 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8687 gfc_conv_descriptor_lbound_get (dest
,
8689 gfc_conv_descriptor_stride_get (dest
,
8691 gfc_add_modify (&block
, tmp2
, tmp
);
8692 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8694 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
8699 /* If a conversion expression has a null data pointer
8700 argument, nullify the allocatable component. */
8704 if (arg
->symtree
->n
.sym
->attr
.allocatable
8705 || arg
->symtree
->n
.sym
->attr
.pointer
)
8707 non_null_expr
= gfc_finish_block (&block
);
8708 gfc_start_block (&block
);
8709 gfc_conv_descriptor_data_set (&block
, dest
,
8711 null_expr
= gfc_finish_block (&block
);
8712 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
8713 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
8714 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8715 return build3_v (COND_EXPR
, tmp
,
8716 null_expr
, non_null_expr
);
8720 return gfc_finish_block (&block
);
8724 /* Allocate or reallocate scalar component, as necessary. */
8727 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
8737 tree lhs_cl_size
= NULL_TREE
;
8742 if (!expr2
|| expr2
->rank
)
8745 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8747 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8749 char name
[GFC_MAX_SYMBOL_LEN
+9];
8750 gfc_component
*strlen
;
8751 /* Use the rhs string length and the lhs element size. */
8752 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8753 if (!expr2
->ts
.u
.cl
->backend_decl
)
8755 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
8756 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
8759 size
= expr2
->ts
.u
.cl
->backend_decl
;
8761 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8763 sprintf (name
, "_%s_length", cm
->name
);
8764 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
8765 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
8766 gfc_charlen_type_node
,
8767 TREE_OPERAND (comp
, 0),
8768 strlen
->backend_decl
, NULL_TREE
);
8770 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8771 tmp
= TYPE_SIZE_UNIT (tmp
);
8772 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8773 TREE_TYPE (tmp
), tmp
,
8774 fold_convert (TREE_TYPE (tmp
), size
));
8776 else if (cm
->ts
.type
== BT_CLASS
)
8778 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8779 if (expr2
->ts
.type
== BT_DERIVED
)
8781 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8782 size
= TYPE_SIZE_UNIT (tmp
);
8788 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8789 gfc_add_vptr_component (e2vtab
);
8790 gfc_add_size_component (e2vtab
);
8791 gfc_init_se (&se
, NULL
);
8792 gfc_conv_expr (&se
, e2vtab
);
8793 gfc_add_block_to_block (block
, &se
.pre
);
8794 size
= fold_convert (size_type_node
, se
.expr
);
8795 gfc_free_expr (e2vtab
);
8797 size_in_bytes
= size
;
8801 /* Otherwise use the length in bytes of the rhs. */
8802 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8803 size_in_bytes
= size
;
8806 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8807 size_in_bytes
, size_one_node
);
8809 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8811 tmp
= build_call_expr_loc (input_location
,
8812 builtin_decl_explicit (BUILT_IN_CALLOC
),
8813 2, build_one_cst (size_type_node
),
8815 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8816 gfc_add_modify (block
, comp
, tmp
);
8820 tmp
= build_call_expr_loc (input_location
,
8821 builtin_decl_explicit (BUILT_IN_MALLOC
),
8823 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8824 ptr
= gfc_class_data_get (comp
);
8827 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8828 gfc_add_modify (block
, ptr
, tmp
);
8831 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8832 /* Update the lhs character length. */
8833 gfc_add_modify (block
, lhs_cl_size
,
8834 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8838 /* Assign a single component of a derived type constructor. */
8841 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8842 gfc_symbol
*sym
, bool init
)
8850 gfc_start_block (&block
);
8852 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8854 /* Only care about pointers here, not about allocatables. */
8855 gfc_init_se (&se
, NULL
);
8856 /* Pointer component. */
8857 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8858 && !cm
->attr
.proc_pointer
)
8860 /* Array pointer. */
8861 if (expr
->expr_type
== EXPR_NULL
)
8862 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8865 se
.direct_byref
= 1;
8867 gfc_conv_expr_descriptor (&se
, expr
);
8868 gfc_add_block_to_block (&block
, &se
.pre
);
8869 gfc_add_block_to_block (&block
, &se
.post
);
8874 /* Scalar pointers. */
8875 se
.want_pointer
= 1;
8876 gfc_conv_expr (&se
, expr
);
8877 gfc_add_block_to_block (&block
, &se
.pre
);
8879 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8880 && expr
->symtree
->n
.sym
->attr
.dummy
)
8881 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8883 gfc_add_modify (&block
, dest
,
8884 fold_convert (TREE_TYPE (dest
), se
.expr
));
8885 gfc_add_block_to_block (&block
, &se
.post
);
8888 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8890 /* NULL initialization for CLASS components. */
8891 tmp
= gfc_trans_structure_assign (dest
,
8892 gfc_class_initializer (&cm
->ts
, expr
),
8894 gfc_add_expr_to_block (&block
, tmp
);
8896 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8897 && !cm
->attr
.proc_pointer
)
8899 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8900 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8901 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8903 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8904 gfc_add_expr_to_block (&block
, tmp
);
8908 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8909 gfc_add_expr_to_block (&block
, tmp
);
8912 else if (cm
->ts
.type
== BT_CLASS
8913 && CLASS_DATA (cm
)->attr
.dimension
8914 && CLASS_DATA (cm
)->attr
.allocatable
8915 && expr
->ts
.type
== BT_DERIVED
)
8917 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8918 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8919 tmp
= gfc_class_vptr_get (dest
);
8920 gfc_add_modify (&block
, tmp
,
8921 fold_convert (TREE_TYPE (tmp
), vtab
));
8922 tmp
= gfc_class_data_get (dest
);
8923 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8924 gfc_add_expr_to_block (&block
, tmp
);
8926 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8928 /* NULL initialization for allocatable components. */
8929 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8930 null_pointer_node
));
8932 else if (init
&& (cm
->attr
.allocatable
8933 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8934 && expr
->ts
.type
!= BT_CLASS
)))
8936 /* Take care about non-array allocatable components here. The alloc_*
8937 routine below is motivated by the alloc_scalar_allocatable_for_
8938 assignment() routine, but with the realloc portions removed and
8940 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8945 /* The remainder of these instructions follow the if (cm->attr.pointer)
8946 if (!cm->attr.dimension) part above. */
8947 gfc_init_se (&se
, NULL
);
8948 gfc_conv_expr (&se
, expr
);
8949 gfc_add_block_to_block (&block
, &se
.pre
);
8951 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8952 && expr
->symtree
->n
.sym
->attr
.dummy
)
8953 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8955 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8957 tmp
= gfc_class_data_get (dest
);
8958 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8959 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8960 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8961 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8962 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8965 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8967 /* For deferred strings insert a memcpy. */
8968 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8971 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8972 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8974 : expr
->ts
.u
.cl
->backend_decl
);
8975 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8976 gfc_add_expr_to_block (&block
, tmp
);
8979 gfc_add_modify (&block
, tmp
,
8980 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8981 gfc_add_block_to_block (&block
, &se
.post
);
8983 else if (expr
->ts
.type
== BT_UNION
)
8986 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8987 /* We mark that the entire union should be initialized with a contrived
8988 EXPR_NULL expression at the beginning. */
8989 if (c
!= NULL
&& c
->n
.component
== NULL
8990 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8992 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8993 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8994 gfc_add_expr_to_block (&block
, tmp
);
8995 c
= gfc_constructor_next (c
);
8997 /* The following constructor expression, if any, represents a specific
8998 map intializer, as given by the user. */
8999 if (c
!= NULL
&& c
->expr
!= NULL
)
9001 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
9002 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
9003 gfc_add_expr_to_block (&block
, tmp
);
9006 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
9008 if (expr
->expr_type
!= EXPR_STRUCTURE
)
9010 tree dealloc
= NULL_TREE
;
9011 gfc_init_se (&se
, NULL
);
9012 gfc_conv_expr (&se
, expr
);
9013 gfc_add_block_to_block (&block
, &se
.pre
);
9014 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
9015 expression in a temporary variable and deallocate the allocatable
9016 components. Then we can the copy the expression to the result. */
9017 if (cm
->ts
.u
.derived
->attr
.alloc_comp
9018 && expr
->expr_type
!= EXPR_VARIABLE
)
9020 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
9021 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
9024 gfc_add_modify (&block
, dest
,
9025 fold_convert (TREE_TYPE (dest
), se
.expr
));
9026 if (cm
->ts
.u
.derived
->attr
.alloc_comp
9027 && expr
->expr_type
!= EXPR_NULL
)
9029 // TODO: Fix caf_mode
9030 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
9031 dest
, expr
->rank
, 0);
9032 gfc_add_expr_to_block (&block
, tmp
);
9033 if (dealloc
!= NULL_TREE
)
9034 gfc_add_expr_to_block (&block
, dealloc
);
9036 gfc_add_block_to_block (&block
, &se
.post
);
9040 /* Nested constructors. */
9041 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
9042 gfc_add_expr_to_block (&block
, tmp
);
9045 else if (gfc_deferred_strlen (cm
, &tmp
))
9049 gcc_assert (strlen
);
9050 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9052 TREE_OPERAND (dest
, 0),
9055 if (expr
->expr_type
== EXPR_NULL
)
9057 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
9058 gfc_add_modify (&block
, dest
, tmp
);
9059 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
9060 gfc_add_modify (&block
, strlen
, tmp
);
9065 gfc_init_se (&se
, NULL
);
9066 gfc_conv_expr (&se
, expr
);
9067 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
9068 tmp
= build_call_expr_loc (input_location
,
9069 builtin_decl_explicit (BUILT_IN_MALLOC
),
9071 gfc_add_modify (&block
, dest
,
9072 fold_convert (TREE_TYPE (dest
), tmp
));
9073 gfc_add_modify (&block
, strlen
,
9074 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
9075 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
9076 gfc_add_expr_to_block (&block
, tmp
);
9079 else if (!cm
->attr
.artificial
)
9081 /* Scalar component (excluding deferred parameters). */
9082 gfc_init_se (&se
, NULL
);
9083 gfc_init_se (&lse
, NULL
);
9085 gfc_conv_expr (&se
, expr
);
9086 if (cm
->ts
.type
== BT_CHARACTER
)
9087 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
9089 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
9090 gfc_add_expr_to_block (&block
, tmp
);
9092 return gfc_finish_block (&block
);
9095 /* Assign a derived type constructor to a variable. */
9098 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
9107 gfc_start_block (&block
);
9109 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
9110 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
9111 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
9115 gfc_init_se (&se
, NULL
);
9116 gfc_init_se (&lse
, NULL
);
9117 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
9119 gfc_add_modify (&block
, lse
.expr
,
9120 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
9122 return gfc_finish_block (&block
);
9125 /* Make sure that the derived type has been completely built. */
9126 if (!expr
->ts
.u
.derived
->backend_decl
9127 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
9129 tmp
= gfc_typenode_for_spec (&expr
->ts
);
9133 cm
= expr
->ts
.u
.derived
->components
;
9137 gfc_init_se (&se
, NULL
);
9139 for (c
= gfc_constructor_first (expr
->value
.constructor
);
9140 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
9142 /* Skip absent members in default initializers. */
9143 if (!c
->expr
&& !cm
->attr
.allocatable
)
9146 /* Register the component with the caf-lib before it is initialized.
9147 Register only allocatable components, that are not coarray'ed
9148 components (%comp[*]). Only register when the constructor is not the
9150 if (coarray
&& !cm
->attr
.codimension
9151 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
9152 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
9154 tree token
, desc
, size
;
9155 bool is_array
= cm
->ts
.type
== BT_CLASS
9156 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
9158 field
= cm
->backend_decl
;
9159 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
9160 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
9161 if (cm
->ts
.type
== BT_CLASS
)
9162 field
= gfc_class_data_get (field
);
9164 token
= is_array
? gfc_conv_descriptor_token (field
)
9165 : fold_build3_loc (input_location
, COMPONENT_REF
,
9166 TREE_TYPE (cm
->caf_token
), dest
,
9167 cm
->caf_token
, NULL_TREE
);
9171 /* The _caf_register routine looks at the rank of the array
9172 descriptor to decide whether the data registered is an array
9174 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
9176 /* When the rank is not known just set a positive rank, which
9177 suffices to recognize the data as array. */
9180 size
= build_zero_cst (size_type_node
);
9182 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
9183 build_int_cst (signed_char_type_node
, rank
));
9187 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
9188 cm
->ts
.type
== BT_CLASS
9189 ? CLASS_DATA (cm
)->attr
9191 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
9193 gfc_add_block_to_block (&block
, &se
.pre
);
9194 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
9195 7, size
, build_int_cst (
9197 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
9198 gfc_build_addr_expr (pvoid_type_node
,
9200 gfc_build_addr_expr (NULL_TREE
, desc
),
9201 null_pointer_node
, null_pointer_node
,
9203 gfc_add_expr_to_block (&block
, tmp
);
9205 field
= cm
->backend_decl
;
9207 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
9208 dest
, field
, NULL_TREE
);
9211 gfc_expr
*e
= gfc_get_null_expr (NULL
);
9212 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
9217 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
9218 expr
->ts
.u
.derived
, init
);
9219 gfc_add_expr_to_block (&block
, tmp
);
9221 return gfc_finish_block (&block
);
9225 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *&v
,
9226 gfc_component
*un
, gfc_expr
*init
)
9228 gfc_constructor
*ctor
;
9230 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
9233 ctor
= gfc_constructor_first (init
->value
.constructor
);
9235 if (ctor
== NULL
|| ctor
->expr
== NULL
)
9238 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
9240 /* If we have an 'initialize all' constructor, do it first. */
9241 if (ctor
->expr
->expr_type
== EXPR_NULL
)
9243 tree union_type
= TREE_TYPE (un
->backend_decl
);
9244 tree val
= build_constructor (union_type
, NULL
);
9245 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
9246 ctor
= gfc_constructor_next (ctor
);
9249 /* Add the map initializer on top. */
9250 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
9252 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
9253 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
9254 TREE_TYPE (un
->backend_decl
),
9255 un
->attr
.dimension
, un
->attr
.pointer
,
9256 un
->attr
.proc_pointer
);
9257 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
9261 /* Build an expression for a constructor. If init is nonzero then
9262 this is part of a static variable initializer. */
9265 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
9272 vec
<constructor_elt
, va_gc
> *v
= NULL
;
9274 gcc_assert (se
->ss
== NULL
);
9275 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
9276 type
= gfc_typenode_for_spec (&expr
->ts
);
9280 /* Create a temporary variable and fill it in. */
9281 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
9282 /* The symtree in expr is NULL, if the code to generate is for
9283 initializing the static members only. */
9284 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
9286 gfc_add_expr_to_block (&se
->pre
, tmp
);
9290 cm
= expr
->ts
.u
.derived
->components
;
9292 for (c
= gfc_constructor_first (expr
->value
.constructor
);
9293 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
9295 /* Skip absent members in default initializers and allocatable
9296 components. Although the latter have a default initializer
9297 of EXPR_NULL,... by default, the static nullify is not needed
9298 since this is done every time we come into scope. */
9299 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
9302 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
9303 && strcmp (cm
->name
, "_extends") == 0
9304 && cm
->initializer
->symtree
)
9308 vtabs
= cm
->initializer
->symtree
->n
.sym
;
9309 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
9310 vtab
= unshare_expr_without_location (vtab
);
9311 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
9313 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
9315 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
9316 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
9317 fold_convert (TREE_TYPE (cm
->backend_decl
),
9320 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
9321 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
9322 fold_convert (TREE_TYPE (cm
->backend_decl
),
9323 integer_zero_node
));
9324 else if (cm
->ts
.type
== BT_UNION
)
9325 gfc_conv_union_initializer (v
, cm
, c
->expr
);
9328 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
9329 TREE_TYPE (cm
->backend_decl
),
9330 cm
->attr
.dimension
, cm
->attr
.pointer
,
9331 cm
->attr
.proc_pointer
);
9332 val
= unshare_expr_without_location (val
);
9334 /* Append it to the constructor list. */
9335 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
9339 se
->expr
= build_constructor (type
, v
);
9341 TREE_CONSTANT (se
->expr
) = 1;
9345 /* Translate a substring expression. */
9348 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
9354 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
9356 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
9357 expr
->value
.character
.length
,
9358 expr
->value
.character
.string
);
9360 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
9361 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
9364 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
9368 /* Entry point for expression translation. Evaluates a scalar quantity.
9369 EXPR is the expression to be translated, and SE is the state structure if
9370 called from within the scalarized. */
9373 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
9378 if (ss
&& ss
->info
->expr
== expr
9379 && (ss
->info
->type
== GFC_SS_SCALAR
9380 || ss
->info
->type
== GFC_SS_REFERENCE
))
9382 gfc_ss_info
*ss_info
;
9385 /* Substitute a scalar expression evaluated outside the scalarization
9387 se
->expr
= ss_info
->data
.scalar
.value
;
9388 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
9389 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9391 se
->string_length
= ss_info
->string_length
;
9392 gfc_advance_se_ss_chain (se
);
9396 /* We need to convert the expressions for the iso_c_binding derived types.
9397 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
9398 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
9399 typespec for the C_PTR and C_FUNPTR symbols, which has already been
9400 updated to be an integer with a kind equal to the size of a (void *). */
9401 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
9402 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
9404 if (expr
->expr_type
== EXPR_VARIABLE
9405 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
9406 || expr
->symtree
->n
.sym
->intmod_sym_id
9407 == ISOCBINDING_NULL_FUNPTR
))
9409 /* Set expr_type to EXPR_NULL, which will result in
9410 null_pointer_node being used below. */
9411 expr
->expr_type
= EXPR_NULL
;
9415 /* Update the type/kind of the expression to be what the new
9416 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
9417 expr
->ts
.type
= BT_INTEGER
;
9418 expr
->ts
.f90_type
= BT_VOID
;
9419 expr
->ts
.kind
= gfc_index_integer_kind
;
9423 gfc_fix_class_refs (expr
);
9425 switch (expr
->expr_type
)
9428 gfc_conv_expr_op (se
, expr
);
9432 gfc_conv_function_expr (se
, expr
);
9436 gfc_conv_constant (se
, expr
);
9440 gfc_conv_variable (se
, expr
);
9444 se
->expr
= null_pointer_node
;
9447 case EXPR_SUBSTRING
:
9448 gfc_conv_substring_expr (se
, expr
);
9451 case EXPR_STRUCTURE
:
9452 gfc_conv_structure (se
, expr
, 0);
9453 /* F2008 4.5.6.3 para 5: If an executable construct references a
9454 structure constructor or array constructor, the entity created by
9455 the constructor is finalized after execution of the innermost
9456 executable construct containing the reference. This, in fact,
9457 was later deleted by the Combined Techical Corrigenda 1 TO 4 for
9458 fortran 2008 (f08/0011). */
9459 if (!gfc_notification_std (GFC_STD_F2018_DEL
) && expr
->must_finalize
9460 && gfc_may_be_finalized (expr
->ts
))
9462 gfc_warning (0, "The structure constructor at %C has been"
9463 " finalized. This feature was removed by f08/0011."
9464 " Use -std=f2018 or -std=gnu to eliminate the"
9466 symbol_attribute attr
;
9467 attr
.allocatable
= attr
.pointer
= 0;
9468 gfc_finalize_tree_expr (se
, expr
->ts
.u
.derived
, attr
, 0);
9469 gfc_add_block_to_block (&se
->post
, &se
->finalblock
);
9474 gfc_conv_array_constructor_expr (se
, expr
);
9475 gfc_add_block_to_block (&se
->post
, &se
->finalblock
);
9484 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9485 of an assignment. */
9487 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
9489 gfc_conv_expr (se
, expr
);
9490 /* All numeric lvalues should have empty post chains. If not we need to
9491 figure out a way of rewriting an lvalue so that it has no post chain. */
9492 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
9495 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9496 numeric expressions. Used for scalar values where inserting cleanup code
9499 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
9503 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
9504 gfc_conv_expr (se
, expr
);
9507 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9508 gfc_add_modify (&se
->pre
, val
, se
->expr
);
9510 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9514 /* Helper to translate an expression and convert it to a particular type. */
9516 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
9518 gfc_conv_expr_val (se
, expr
);
9519 se
->expr
= convert (type
, se
->expr
);
9523 /* Converts an expression so that it can be passed by reference. Scalar
9527 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
9533 if (ss
&& ss
->info
->expr
== expr
9534 && ss
->info
->type
== GFC_SS_REFERENCE
)
9536 /* Returns a reference to the scalar evaluated outside the loop
9538 gfc_conv_expr (se
, expr
);
9540 if (expr
->ts
.type
== BT_CHARACTER
9541 && expr
->expr_type
!= EXPR_FUNCTION
)
9542 gfc_conv_string_parameter (se
);
9544 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
9549 if (expr
->ts
.type
== BT_CHARACTER
)
9551 gfc_conv_expr (se
, expr
);
9552 gfc_conv_string_parameter (se
);
9556 if (expr
->expr_type
== EXPR_VARIABLE
)
9558 se
->want_pointer
= 1;
9559 gfc_conv_expr (se
, expr
);
9562 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9563 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9564 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9570 if (expr
->expr_type
== EXPR_FUNCTION
9571 && ((expr
->value
.function
.esym
9572 && expr
->value
.function
.esym
->result
9573 && expr
->value
.function
.esym
->result
->attr
.pointer
9574 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
9575 || (!expr
->value
.function
.esym
&& !expr
->ref
9576 && expr
->symtree
->n
.sym
->attr
.pointer
9577 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
9579 se
->want_pointer
= 1;
9580 gfc_conv_expr (se
, expr
);
9581 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9582 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9587 gfc_conv_expr (se
, expr
);
9589 /* Create a temporary var to hold the value. */
9590 if (TREE_CONSTANT (se
->expr
))
9592 tree tmp
= se
->expr
;
9593 STRIP_TYPE_NOPS (tmp
);
9594 var
= build_decl (input_location
,
9595 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
9596 DECL_INITIAL (var
) = tmp
;
9597 TREE_STATIC (var
) = 1;
9602 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9603 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9606 if (!expr
->must_finalize
)
9607 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9609 /* Take the address of that value. */
9610 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
9614 /* Get the _len component for an unlimited polymorphic expression. */
9617 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
9620 gfc_ref
*ref
= expr
->ref
;
9622 gfc_init_se (&se
, NULL
);
9623 while (ref
&& ref
->next
)
9625 gfc_add_len_component (expr
);
9626 gfc_conv_expr (&se
, expr
);
9627 gfc_add_block_to_block (block
, &se
.pre
);
9628 gcc_assert (se
.post
.head
== NULL_TREE
);
9631 gfc_free_ref_list (ref
->next
);
9636 gfc_free_ref_list (expr
->ref
);
9643 /* Assign _vptr and _len components as appropriate. BLOCK should be a
9644 statement-list outside of the scalarizer-loop. When code is generated, that
9645 depends on the scalarized expression, it is added to RSE.PRE.
9646 Returns le's _vptr tree and when set the len expressions in to_lenp and
9647 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9651 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
9652 gfc_expr
* re
, gfc_se
*rse
,
9653 tree
* to_lenp
, tree
* from_lenp
)
9656 gfc_expr
* vptr_expr
;
9657 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
9658 bool set_vptr
= false, temp_rhs
= false;
9659 stmtblock_t
*pre
= block
;
9660 tree class_expr
= NULL_TREE
;
9662 /* Create a temporary for complicated expressions. */
9663 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
9664 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
9666 if (re
->ts
.type
== BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9667 class_expr
= gfc_get_class_from_expr (rse
->expr
);
9670 pre
= &rse
->loop
->pre
;
9674 if (class_expr
!= NULL_TREE
&& UNLIMITED_POLY (re
))
9676 tmp
= TREE_OPERAND (rse
->expr
, 0);
9677 tmp
= gfc_create_var (TREE_TYPE (tmp
), "rhs");
9678 gfc_add_modify (&rse
->pre
, tmp
, TREE_OPERAND (rse
->expr
, 0));
9682 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
9683 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
9690 /* Get the _vptr for the left-hand side expression. */
9691 gfc_init_se (&se
, NULL
);
9692 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
9693 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
9695 /* Care about _len for unlimited polymorphic entities. */
9696 if (UNLIMITED_POLY (vptr_expr
)
9697 || (vptr_expr
->ts
.type
== BT_DERIVED
9698 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9699 to_len
= trans_get_upoly_len (block
, vptr_expr
);
9700 gfc_add_vptr_component (vptr_expr
);
9704 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9705 se
.want_pointer
= 1;
9706 gfc_conv_expr (&se
, vptr_expr
);
9707 gfc_free_expr (vptr_expr
);
9708 gfc_add_block_to_block (block
, &se
.pre
);
9709 gcc_assert (se
.post
.head
== NULL_TREE
);
9711 STRIP_NOPS (lhs_vptr
);
9713 /* Set the _vptr only when the left-hand side of the assignment is a
9717 /* Get the vptr from the rhs expression only, when it is variable.
9718 Functions are expected to be assigned to a temporary beforehand. */
9719 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
9720 ? gfc_find_and_cut_at_last_class_ref (re
)
9722 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
9724 if (to_len
!= NULL_TREE
)
9726 /* Get the _len information from the rhs. */
9727 if (UNLIMITED_POLY (vptr_expr
)
9728 || (vptr_expr
->ts
.type
== BT_DERIVED
9729 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9730 from_len
= trans_get_upoly_len (block
, vptr_expr
);
9732 gfc_add_vptr_component (vptr_expr
);
9736 if (re
->expr_type
== EXPR_VARIABLE
9737 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
9738 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
9739 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
9740 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
9741 re
->symtree
->n
.sym
->backend_decl
))))
9744 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
9745 re
->symtree
->n
.sym
->backend_decl
));
9747 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
9748 re
->symtree
->n
.sym
->backend_decl
));
9750 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
9755 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9756 tmp
= gfc_get_class_from_expr (rse
->expr
);
9760 se
.expr
= gfc_class_vptr_get (tmp
);
9761 if (UNLIMITED_POLY (re
))
9762 from_len
= gfc_class_len_get (tmp
);
9765 else if (re
->expr_type
!= EXPR_NULL
)
9766 /* Only when rhs is non-NULL use its declared type for vptr
9768 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
9770 /* When the rhs is NULL use the vtab of lhs' declared type. */
9771 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9776 gfc_init_se (&se
, NULL
);
9777 se
.want_pointer
= 1;
9778 gfc_conv_expr (&se
, vptr_expr
);
9779 gfc_free_expr (vptr_expr
);
9780 gfc_add_block_to_block (block
, &se
.pre
);
9781 gcc_assert (se
.post
.head
== NULL_TREE
);
9783 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
9786 if (to_len
!= NULL_TREE
)
9788 /* The _len component needs to be set. Figure how to get the
9789 value of the right-hand side. */
9790 if (from_len
== NULL_TREE
)
9792 if (rse
->string_length
!= NULL_TREE
)
9793 from_len
= rse
->string_length
;
9794 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
9796 gfc_init_se (&se
, NULL
);
9797 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
9798 gfc_add_block_to_block (block
, &se
.pre
);
9799 gcc_assert (se
.post
.head
== NULL_TREE
);
9800 from_len
= gfc_evaluate_now (se
.expr
, block
);
9803 from_len
= build_zero_cst (gfc_charlen_type_node
);
9805 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9810 /* Return the _len trees only, when requested. */
9814 *from_lenp
= from_len
;
9819 /* Assign tokens for pointer components. */
9822 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9825 symbol_attribute lhs_attr
, rhs_attr
;
9826 tree tmp
, lhs_tok
, rhs_tok
;
9827 /* Flag to indicated component refs on the rhs. */
9830 lhs_attr
= gfc_caf_attr (expr1
);
9831 if (expr2
->expr_type
!= EXPR_NULL
)
9833 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9834 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9836 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9837 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9840 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9844 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9845 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9848 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9850 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9851 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9854 else if (lhs_attr
.codimension
)
9856 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9857 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9858 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9859 lhs_tok
, null_pointer_node
);
9860 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9865 /* Do everything that is needed for a CLASS function expr2. */
9868 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9869 gfc_expr
*expr1
, gfc_expr
*expr2
)
9871 tree expr1_vptr
= NULL_TREE
;
9874 gfc_conv_function_expr (rse
, expr2
);
9875 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9877 if (expr1
->ts
.type
!= BT_CLASS
)
9878 rse
->expr
= gfc_class_data_get (rse
->expr
);
9881 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9884 gfc_add_block_to_block (block
, &rse
->pre
);
9885 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9886 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9888 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9889 fold_convert (TREE_TYPE (expr1_vptr
),
9890 gfc_class_vptr_get (tmp
)));
9891 rse
->expr
= gfc_class_data_get (tmp
);
9899 gfc_trans_pointer_assign (gfc_code
* code
)
9901 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9905 /* Generate code for a pointer assignment. */
9908 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9915 tree expr1_vptr
= NULL_TREE
;
9916 bool scalar
, non_proc_ptr_assign
;
9919 gfc_start_block (&block
);
9921 gfc_init_se (&lse
, NULL
);
9923 /* Usually testing whether this is not a proc pointer assignment. */
9924 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9925 && expr2
->expr_type
== EXPR_VARIABLE
9926 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9928 /* Check whether the expression is a scalar or not; we cannot use
9929 expr1->rank as it can be nonzero for proc pointers. */
9930 ss
= gfc_walk_expr (expr1
);
9931 scalar
= ss
== gfc_ss_terminator
;
9933 gfc_free_ss_chain (ss
);
9935 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9936 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9938 gfc_add_data_component (expr2
);
9939 /* The following is required as gfc_add_data_component doesn't
9940 update ts.type if there is a trailing REF_ARRAY. */
9941 expr2
->ts
.type
= BT_DERIVED
;
9946 /* Scalar pointers. */
9947 lse
.want_pointer
= 1;
9948 gfc_conv_expr (&lse
, expr1
);
9949 gfc_init_se (&rse
, NULL
);
9950 rse
.want_pointer
= 1;
9951 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9952 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9954 gfc_conv_expr (&rse
, expr2
);
9956 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9958 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9960 lse
.expr
= gfc_class_data_get (lse
.expr
);
9963 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9964 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9965 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9968 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9969 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9970 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9973 gfc_add_block_to_block (&block
, &lse
.pre
);
9974 gfc_add_block_to_block (&block
, &rse
.pre
);
9976 /* Check character lengths if character expression. The test is only
9977 really added if -fbounds-check is enabled. Exclude deferred
9978 character length lefthand sides. */
9979 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9980 && !expr1
->ts
.deferred
9981 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9982 && !gfc_is_proc_ptr_comp (expr1
))
9984 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9985 gcc_assert (lse
.string_length
&& rse
.string_length
);
9986 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9987 lse
.string_length
, rse
.string_length
,
9991 /* The assignment to an deferred character length sets the string
9992 length to that of the rhs. */
9993 if (expr1
->ts
.deferred
)
9995 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9996 gfc_add_modify (&block
, lse
.string_length
,
9997 fold_convert (TREE_TYPE (lse
.string_length
),
9998 rse
.string_length
));
9999 else if (lse
.string_length
!= NULL
)
10000 gfc_add_modify (&block
, lse
.string_length
,
10001 build_zero_cst (TREE_TYPE (lse
.string_length
)));
10004 gfc_add_modify (&block
, lse
.expr
,
10005 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
10007 /* Also set the tokens for pointer components in derived typed
10009 if (flag_coarray
== GFC_FCOARRAY_LIB
)
10010 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
10012 gfc_add_block_to_block (&block
, &rse
.post
);
10013 gfc_add_block_to_block (&block
, &lse
.post
);
10020 tree strlen_rhs
= NULL_TREE
;
10022 /* Array pointer. Find the last reference on the LHS and if it is an
10023 array section ref, we're dealing with bounds remapping. In this case,
10024 set it to AR_FULL so that gfc_conv_expr_descriptor does
10025 not see it and process the bounds remapping afterwards explicitly. */
10026 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
10027 if (!remap
->next
&& remap
->type
== REF_ARRAY
10028 && remap
->u
.ar
.type
== AR_SECTION
)
10030 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
10032 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
10034 gfc_error ("If bounds remapping is specified at %L, "
10035 "the pointer target shall not be NULL", &expr1
->where
);
10039 gfc_init_se (&lse
, NULL
);
10041 lse
.descriptor_only
= 1;
10042 gfc_conv_expr_descriptor (&lse
, expr1
);
10043 strlen_lhs
= lse
.string_length
;
10046 if (expr2
->expr_type
== EXPR_NULL
)
10048 /* Just set the data pointer to null. */
10049 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
10051 else if (rank_remap
)
10053 /* If we are rank-remapping, just get the RHS's descriptor and
10054 process this later on. */
10055 gfc_init_se (&rse
, NULL
);
10056 rse
.direct_byref
= 1;
10057 rse
.byref_noassign
= 1;
10059 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
10060 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
10062 else if (expr2
->expr_type
== EXPR_FUNCTION
)
10064 tree bound
[GFC_MAX_DIMENSIONS
];
10067 for (i
= 0; i
< expr2
->rank
; i
++)
10068 bound
[i
] = NULL_TREE
;
10069 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
10070 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
10072 GFC_ARRAY_POINTER_CONT
, false);
10073 tmp
= gfc_create_var (tmp
, "ptrtemp");
10074 rse
.descriptor_only
= 0;
10076 rse
.direct_byref
= 1;
10077 gfc_conv_expr_descriptor (&rse
, expr2
);
10078 strlen_rhs
= rse
.string_length
;
10083 gfc_conv_expr_descriptor (&rse
, expr2
);
10084 strlen_rhs
= rse
.string_length
;
10085 if (expr1
->ts
.type
== BT_CLASS
)
10086 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
10091 else if (expr2
->expr_type
== EXPR_VARIABLE
)
10093 /* Assign directly to the LHS's descriptor. */
10094 lse
.descriptor_only
= 0;
10095 lse
.direct_byref
= 1;
10096 gfc_conv_expr_descriptor (&lse
, expr2
);
10097 strlen_rhs
= lse
.string_length
;
10098 gfc_init_se (&rse
, NULL
);
10100 if (expr1
->ts
.type
== BT_CLASS
)
10102 rse
.expr
= NULL_TREE
;
10103 rse
.string_length
= strlen_rhs
;
10104 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
10110 /* If the target is not a whole array, use the target array
10111 reference for remap. */
10112 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
10113 if (remap
->type
== REF_ARRAY
10114 && remap
->u
.ar
.type
== AR_FULL
10119 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
10121 gfc_init_se (&rse
, NULL
);
10122 rse
.want_pointer
= 1;
10123 gfc_conv_function_expr (&rse
, expr2
);
10124 if (expr1
->ts
.type
!= BT_CLASS
)
10126 rse
.expr
= gfc_class_data_get (rse
.expr
);
10127 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
10128 /* Set the lhs span. */
10129 tmp
= TREE_TYPE (rse
.expr
);
10130 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
10131 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10132 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
10136 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
10139 gfc_add_block_to_block (&block
, &rse
.pre
);
10140 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
10141 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
10143 gfc_add_modify (&lse
.pre
, expr1_vptr
,
10144 fold_convert (TREE_TYPE (expr1_vptr
),
10145 gfc_class_vptr_get (tmp
)));
10146 rse
.expr
= gfc_class_data_get (tmp
);
10147 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
10152 /* Assign to a temporary descriptor and then copy that
10153 temporary to the pointer. */
10154 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
10155 lse
.descriptor_only
= 0;
10157 lse
.direct_byref
= 1;
10158 gfc_conv_expr_descriptor (&lse
, expr2
);
10159 strlen_rhs
= lse
.string_length
;
10160 gfc_add_modify (&lse
.pre
, desc
, tmp
);
10163 if (expr1
->ts
.type
== BT_CHARACTER
10164 && expr1
->symtree
->n
.sym
->ts
.deferred
10165 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
10166 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
10168 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
10169 if (expr2
->expr_type
!= EXPR_NULL
)
10170 gfc_add_modify (&block
, tmp
,
10171 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
10173 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
10176 gfc_add_block_to_block (&block
, &lse
.pre
);
10178 gfc_add_block_to_block (&block
, &rse
.pre
);
10180 /* If we do bounds remapping, update LHS descriptor accordingly. */
10184 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
10188 /* Do rank remapping. We already have the RHS's descriptor
10189 converted in rse and now have to build the correct LHS
10190 descriptor for it. */
10192 tree dtype
, data
, span
;
10194 tree lbound
, ubound
;
10197 dtype
= gfc_conv_descriptor_dtype (desc
);
10198 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
10199 gfc_add_modify (&block
, dtype
, tmp
);
10201 /* Copy data pointer. */
10202 data
= gfc_conv_descriptor_data_get (rse
.expr
);
10203 gfc_conv_descriptor_data_set (&block
, desc
, data
);
10205 /* Copy the span. */
10206 if (TREE_CODE (rse
.expr
) == VAR_DECL
10207 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
10208 span
= gfc_conv_descriptor_span_get (rse
.expr
);
10211 tmp
= TREE_TYPE (rse
.expr
);
10212 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
10213 span
= fold_convert (gfc_array_index_type
, tmp
);
10215 gfc_conv_descriptor_span_set (&block
, desc
, span
);
10217 /* Copy offset but adjust it such that it would correspond
10218 to a lbound of zero. */
10219 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
10220 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
10222 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
10223 gfc_rank_cst
[dim
]);
10224 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
10225 gfc_rank_cst
[dim
]);
10226 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10227 gfc_array_index_type
, stride
, lbound
);
10228 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
10229 gfc_array_index_type
, offs
, tmp
);
10231 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
10233 /* Set the bounds as declared for the LHS and calculate strides as
10234 well as another offset update accordingly. */
10235 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
10237 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
10242 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
10244 /* Convert declared bounds. */
10245 gfc_init_se (&lower_se
, NULL
);
10246 gfc_init_se (&upper_se
, NULL
);
10247 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
10248 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
10250 gfc_add_block_to_block (&block
, &lower_se
.pre
);
10251 gfc_add_block_to_block (&block
, &upper_se
.pre
);
10253 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
10254 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
10256 lbound
= gfc_evaluate_now (lbound
, &block
);
10257 ubound
= gfc_evaluate_now (ubound
, &block
);
10259 gfc_add_block_to_block (&block
, &lower_se
.post
);
10260 gfc_add_block_to_block (&block
, &upper_se
.post
);
10262 /* Set bounds in descriptor. */
10263 gfc_conv_descriptor_lbound_set (&block
, desc
,
10264 gfc_rank_cst
[dim
], lbound
);
10265 gfc_conv_descriptor_ubound_set (&block
, desc
,
10266 gfc_rank_cst
[dim
], ubound
);
10269 stride
= gfc_evaluate_now (stride
, &block
);
10270 gfc_conv_descriptor_stride_set (&block
, desc
,
10271 gfc_rank_cst
[dim
], stride
);
10273 /* Update offset. */
10274 offs
= gfc_conv_descriptor_offset_get (desc
);
10275 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10276 gfc_array_index_type
, lbound
, stride
);
10277 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
10278 gfc_array_index_type
, offs
, tmp
);
10279 offs
= gfc_evaluate_now (offs
, &block
);
10280 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
10282 /* Update stride. */
10283 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10284 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
10285 gfc_array_index_type
, stride
, tmp
);
10290 /* Bounds remapping. Just shift the lower bounds. */
10292 gcc_assert (expr1
->rank
== expr2
->rank
);
10294 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
10298 gcc_assert (!remap
->u
.ar
.end
[dim
]);
10299 gfc_init_se (&lbound_se
, NULL
);
10300 if (remap
->u
.ar
.start
[dim
])
10302 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
10303 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
10306 /* This remap arises from a target that is not a whole
10307 array. The start expressions will be NULL but we need
10308 the lbounds to be one. */
10309 lbound_se
.expr
= gfc_index_one_node
;
10310 gfc_conv_shift_descriptor_lbound (&block
, desc
,
10311 dim
, lbound_se
.expr
);
10312 gfc_add_block_to_block (&block
, &lbound_se
.post
);
10317 /* If rank remapping was done, check with -fcheck=bounds that
10318 the target is at least as large as the pointer. */
10319 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
10325 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
10326 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
10328 lsize
= gfc_evaluate_now (lsize
, &block
);
10329 rsize
= gfc_evaluate_now (rsize
, &block
);
10330 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
10333 msg
= _("Target of rank remapping is too small (%ld < %ld)");
10334 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
10335 msg
, rsize
, lsize
);
10338 /* Check string lengths if applicable. The check is only really added
10339 to the output code if -fbounds-check is enabled. */
10340 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
10342 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
10343 gcc_assert (strlen_lhs
&& strlen_rhs
);
10344 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
10345 strlen_lhs
, strlen_rhs
, &block
);
10348 gfc_add_block_to_block (&block
, &lse
.post
);
10350 gfc_add_block_to_block (&block
, &rse
.post
);
10353 return gfc_finish_block (&block
);
10357 /* Makes sure se is suitable for passing as a function string parameter. */
10358 /* TODO: Need to check all callers of this function. It may be abused. */
10361 gfc_conv_string_parameter (gfc_se
* se
)
10365 if (TREE_CODE (se
->expr
) == STRING_CST
)
10367 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
10368 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
10372 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
10373 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
10374 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
10376 type
= TREE_TYPE (se
->expr
);
10377 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
10378 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
10381 if (TREE_CODE (type
) == ARRAY_TYPE
)
10382 type
= TREE_TYPE (type
);
10383 type
= gfc_get_character_type_len_for_eltype (type
,
10384 se
->string_length
);
10385 type
= build_pointer_type (type
);
10386 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
10390 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
10394 /* Generate code for assignment of scalar variables. Includes character
10395 strings and derived types with allocatable components.
10396 If you know that the LHS has no allocations, set dealloc to false.
10398 DEEP_COPY has no effect if the typespec TS is not a derived type with
10399 allocatable components. Otherwise, if it is set, an explicit copy of each
10400 allocatable component is made. This is necessary as a simple copy of the
10401 whole object would copy array descriptors as is, so that the lhs's
10402 allocatable components would point to the rhs's after the assignment.
10403 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
10404 necessary if the rhs is a non-pointer function, as the allocatable components
10405 are not accessible by other means than the function's result after the
10406 function has returned. It is even more subtle when temporaries are involved,
10407 as the two following examples show:
10408 1. When we evaluate an array constructor, a temporary is created. Thus
10409 there is theoretically no alias possible. However, no deep copy is
10410 made for this temporary, so that if the constructor is made of one or
10411 more variable with allocatable components, those components still point
10412 to the variable's: DEEP_COPY should be set for the assignment from the
10413 temporary to the lhs in that case.
10414 2. When assigning a scalar to an array, we evaluate the scalar value out
10415 of the loop, store it into a temporary variable, and assign from that.
10416 In that case, deep copying when assigning to the temporary would be a
10417 waste of resources; however deep copies should happen when assigning from
10418 the temporary to each array element: again DEEP_COPY should be set for
10419 the assignment from the temporary to the lhs. */
10422 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
10423 bool deep_copy
, bool dealloc
, bool in_coarray
)
10429 gfc_init_block (&block
);
10431 if (ts
.type
== BT_CHARACTER
)
10436 if (lse
->string_length
!= NULL_TREE
)
10438 gfc_conv_string_parameter (lse
);
10439 gfc_add_block_to_block (&block
, &lse
->pre
);
10440 llen
= lse
->string_length
;
10443 if (rse
->string_length
!= NULL_TREE
)
10445 gfc_conv_string_parameter (rse
);
10446 gfc_add_block_to_block (&block
, &rse
->pre
);
10447 rlen
= rse
->string_length
;
10450 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
10451 rse
->expr
, ts
.kind
);
10453 else if (gfc_bt_struct (ts
.type
)
10454 && (ts
.u
.derived
->attr
.alloc_comp
10455 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
10457 tree tmp_var
= NULL_TREE
;
10460 /* Are the rhs and the lhs the same? */
10463 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10464 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
10465 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
10466 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
10469 /* Deallocate the lhs allocated components as long as it is not
10470 the same as the rhs. This must be done following the assignment
10471 to prevent deallocating data that could be used in the rhs
10475 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
10476 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
,
10479 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10481 gfc_add_expr_to_block (&lse
->post
, tmp
);
10484 gfc_add_block_to_block (&block
, &rse
->pre
);
10485 gfc_add_block_to_block (&block
, &lse
->finalblock
);
10486 gfc_add_block_to_block (&block
, &lse
->pre
);
10488 gfc_add_modify (&block
, lse
->expr
,
10489 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
10491 /* Restore pointer address of coarray components. */
10492 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
10494 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
10495 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10497 gfc_add_expr_to_block (&block
, tmp
);
10500 /* Do a deep copy if the rhs is a variable, if it is not the
10501 same as the lhs. */
10504 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10505 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
10506 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
10508 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10510 gfc_add_expr_to_block (&block
, tmp
);
10513 else if (gfc_bt_struct (ts
.type
))
10515 gfc_add_block_to_block (&block
, &rse
->pre
);
10516 gfc_add_block_to_block (&block
, &lse
->finalblock
);
10517 gfc_add_block_to_block (&block
, &lse
->pre
);
10518 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
10519 TREE_TYPE (lse
->expr
), rse
->expr
);
10520 gfc_add_modify (&block
, lse
->expr
, tmp
);
10522 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10523 else if (ts
.type
== BT_CLASS
)
10525 gfc_add_block_to_block (&block
, &lse
->pre
);
10526 gfc_add_block_to_block (&block
, &rse
->pre
);
10527 gfc_add_block_to_block (&block
, &lse
->finalblock
);
10529 if (!trans_scalar_class_assign (&block
, lse
, rse
))
10531 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10532 for the lhs which ensures that class data rhs cast as a string assigns
10534 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
10535 TREE_TYPE (rse
->expr
), lse
->expr
);
10536 gfc_add_modify (&block
, tmp
, rse
->expr
);
10539 else if (ts
.type
!= BT_CLASS
)
10541 gfc_add_block_to_block (&block
, &lse
->pre
);
10542 gfc_add_block_to_block (&block
, &rse
->pre
);
10544 gfc_add_modify (&block
, lse
->expr
,
10545 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
10548 gfc_add_block_to_block (&block
, &lse
->post
);
10549 gfc_add_block_to_block (&block
, &rse
->post
);
10551 return gfc_finish_block (&block
);
10555 /* There are quite a lot of restrictions on the optimisation in using an
10556 array function assign without a temporary. */
10559 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
10562 bool seen_array_ref
;
10564 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
10566 /* Play it safe with class functions assigned to a derived type. */
10567 if (gfc_is_class_array_function (expr2
)
10568 && expr1
->ts
.type
== BT_DERIVED
)
10571 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10572 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
10575 /* Elemental functions are scalarized so that they don't need a
10576 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10577 they would need special treatment in gfc_trans_arrayfunc_assign. */
10578 if (expr2
->value
.function
.esym
!= NULL
10579 && expr2
->value
.function
.esym
->attr
.elemental
)
10582 /* Need a temporary if rhs is not FULL or a contiguous section. */
10583 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
10586 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10587 if (gfc_ref_needs_temporary_p (expr1
->ref
))
10590 /* Functions returning pointers or allocatables need temporaries. */
10591 if (gfc_expr_attr (expr2
).pointer
10592 || gfc_expr_attr (expr2
).allocatable
)
10595 /* Character array functions need temporaries unless the
10596 character lengths are the same. */
10597 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
10599 if (expr1
->ts
.u
.cl
->length
== NULL
10600 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10603 if (expr2
->ts
.u
.cl
->length
== NULL
10604 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10607 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
10608 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
10612 /* Check that no LHS component references appear during an array
10613 reference. This is needed because we do not have the means to
10614 span any arbitrary stride with an array descriptor. This check
10615 is not needed for the rhs because the function result has to be
10616 a complete type. */
10617 seen_array_ref
= false;
10618 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10620 if (ref
->type
== REF_ARRAY
)
10621 seen_array_ref
= true;
10622 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
10626 /* Check for a dependency. */
10627 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
10628 expr2
->value
.function
.esym
,
10629 expr2
->value
.function
.actual
,
10633 /* If we have reached here with an intrinsic function, we do not
10634 need a temporary except in the particular case that reallocation
10635 on assignment is active and the lhs is allocatable and a target,
10636 or a pointer which may be a subref pointer. FIXME: The last
10637 condition can go away when we use span in the intrinsics
10639 if (expr2
->value
.function
.isym
)
10640 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
)
10641 || (sym
->attr
.pointer
&& sym
->attr
.subref_array_pointer
);
10643 /* If the LHS is a dummy, we need a temporary if it is not
10645 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
10648 /* If the lhs has been host_associated, is in common, a pointer or is
10649 a target and the function is not using a RESULT variable, aliasing
10650 can occur and a temporary is needed. */
10651 if ((sym
->attr
.host_assoc
10652 || sym
->attr
.in_common
10653 || sym
->attr
.pointer
10654 || sym
->attr
.cray_pointee
10655 || sym
->attr
.target
)
10656 && expr2
->symtree
!= NULL
10657 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
10660 /* A PURE function can unconditionally be called without a temporary. */
10661 if (expr2
->value
.function
.esym
!= NULL
10662 && expr2
->value
.function
.esym
->attr
.pure
)
10665 /* Implicit_pure functions are those which could legally be declared
10667 if (expr2
->value
.function
.esym
!= NULL
10668 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
10671 if (!sym
->attr
.use_assoc
10672 && !sym
->attr
.in_common
10673 && !sym
->attr
.pointer
10674 && !sym
->attr
.target
10675 && !sym
->attr
.cray_pointee
10676 && expr2
->value
.function
.esym
)
10678 /* A temporary is not needed if the function is not contained and
10679 the variable is local or host associated and not a pointer or
10681 if (!expr2
->value
.function
.esym
->attr
.contained
)
10684 /* A temporary is not needed if the lhs has never been host
10685 associated and the procedure is contained. */
10686 else if (!sym
->attr
.host_assoc
)
10689 /* A temporary is not needed if the variable is local and not
10690 a pointer, a target or a result. */
10691 if (sym
->ns
->parent
10692 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
10696 /* Default to temporary use. */
10701 /* Provide the loop info so that the lhs descriptor can be built for
10702 reallocatable assignments from extrinsic function calls. */
10705 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
10706 gfc_loopinfo
*loop
)
10708 /* Signal that the function call should not be made by
10709 gfc_conv_loop_setup. */
10710 se
->ss
->is_alloc_lhs
= 1;
10711 gfc_init_loopinfo (loop
);
10712 gfc_add_ss_to_loop (loop
, *ss
);
10713 gfc_add_ss_to_loop (loop
, se
->ss
);
10714 gfc_conv_ss_startstride (loop
);
10715 gfc_conv_loop_setup (loop
, where
);
10716 gfc_copy_loopinfo_to_se (se
, loop
);
10717 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
10718 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
10719 se
->ss
->is_alloc_lhs
= 0;
10723 /* For assignment to a reallocatable lhs from intrinsic functions,
10724 replace the se.expr (ie. the result) with a temporary descriptor.
10725 Null the data field so that the library allocates space for the
10726 result. Free the data of the original descriptor after the function,
10727 in case it appears in an argument expression and transfer the
10728 result to the original descriptor. */
10731 fcncall_realloc_result (gfc_se
*se
, int rank
)
10738 tree not_same_shape
;
10739 stmtblock_t shape_block
;
10742 /* Use the allocation done by the library. Substitute the lhs
10743 descriptor with a copy, whose data field is nulled.*/
10744 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
10745 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
10746 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
10748 /* Unallocated, the descriptor does not have a dtype. */
10749 tmp
= gfc_conv_descriptor_dtype (desc
);
10750 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10752 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
10753 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
10754 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
10756 /* Free the lhs after the function call and copy the result data to
10757 the lhs descriptor. */
10758 tmp
= gfc_conv_descriptor_data_get (desc
);
10759 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10760 logical_type_node
, tmp
,
10761 build_int_cst (TREE_TYPE (tmp
), 0));
10762 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
10763 tmp
= gfc_call_free (tmp
);
10764 gfc_add_expr_to_block (&se
->post
, tmp
);
10766 tmp
= gfc_conv_descriptor_data_get (res_desc
);
10767 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
10769 /* Check that the shapes are the same between lhs and expression.
10770 The evaluation of the shape is done in 'shape_block' to avoid
10771 unitialized warnings from the lhs bounds. */
10772 not_same_shape
= boolean_false_node
;
10773 gfc_start_block (&shape_block
);
10774 for (n
= 0 ; n
< rank
; n
++)
10777 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10778 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
10779 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10780 gfc_array_index_type
, tmp
, tmp1
);
10781 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10782 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10783 gfc_array_index_type
, tmp
, tmp1
);
10784 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10785 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10786 gfc_array_index_type
, tmp
, tmp1
);
10787 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10788 logical_type_node
, tmp
,
10789 gfc_index_zero_node
);
10790 tmp
= gfc_evaluate_now (tmp
, &shape_block
);
10792 not_same_shape
= tmp
;
10794 not_same_shape
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10795 logical_type_node
, tmp
,
10799 /* 'zero_cond' being true is equal to lhs not being allocated or the
10800 shapes being different. */
10801 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
10802 zero_cond
, not_same_shape
);
10803 gfc_add_modify (&shape_block
, zero_cond
, tmp
);
10804 tmp
= gfc_finish_block (&shape_block
);
10805 tmp
= build3_v (COND_EXPR
, zero_cond
,
10806 build_empty_stmt (input_location
), tmp
);
10807 gfc_add_expr_to_block (&se
->post
, tmp
);
10809 /* Now reset the bounds returned from the function call to bounds based
10810 on the lhs lbounds, except where the lhs is not allocated or the shapes
10811 of 'variable and 'expr' are different. Set the offset accordingly. */
10812 offset
= gfc_index_zero_node
;
10813 for (n
= 0 ; n
< rank
; n
++)
10817 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10818 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
10819 gfc_array_index_type
, zero_cond
,
10820 gfc_index_one_node
, lbound
);
10821 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
10823 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10824 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10825 gfc_array_index_type
, tmp
, lbound
);
10826 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
10827 gfc_rank_cst
[n
], lbound
);
10828 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
10829 gfc_rank_cst
[n
], tmp
);
10831 /* Set stride and accumulate the offset. */
10832 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
10833 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
10834 gfc_rank_cst
[n
], tmp
);
10835 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10836 gfc_array_index_type
, lbound
, tmp
);
10837 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10838 gfc_array_index_type
, offset
, tmp
);
10839 offset
= gfc_evaluate_now (offset
, &se
->post
);
10842 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10847 /* Try to translate array(:) = func (...), where func is a transformational
10848 array function, without using a temporary. Returns NULL if this isn't the
10852 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10856 gfc_component
*comp
= NULL
;
10861 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
10862 bool finalizable
= gfc_may_be_finalized (expr1
->ts
);
10864 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10867 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10869 comp
= gfc_get_proc_ptr_comp (expr2
);
10871 if (!(expr2
->value
.function
.isym
10872 || (comp
&& comp
->attr
.dimension
)
10873 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10874 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10877 gfc_init_se (&se
, NULL
);
10878 gfc_start_block (&se
.pre
);
10879 se
.want_pointer
= 1;
10881 /* First the lhs must be finalized, if necessary. We use a copy of the symbol
10882 backend decl, stash the original away for the finalization so that the
10883 value used is that before the assignment. This is necessary because
10884 evaluation of the rhs expression using direct by reference can change
10885 the value. However, the standard mandates that the finalization must occur
10886 after evaluation of the rhs. */
10887 gfc_init_se (&final_se
, NULL
);
10891 tmp
= sym
->backend_decl
;
10892 lhs
= sym
->backend_decl
;
10893 if (TREE_CODE (tmp
) == INDIRECT_REF
)
10894 tmp
= TREE_OPERAND (tmp
, 0);
10895 sym
->backend_decl
= gfc_create_var (TREE_TYPE (tmp
), "lhs");
10896 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
10897 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
10899 tmp
= gfc_copy_alloc_comp (expr1
->ts
.u
.derived
, tmp
, sym
->backend_decl
,
10901 gfc_add_expr_to_block (&final_se
.pre
, tmp
);
10905 if (finalizable
&& gfc_assignment_finalizer_call (&final_se
, expr1
, false))
10907 gfc_add_block_to_block (&se
.pre
, &final_se
.pre
);
10908 gfc_add_block_to_block (&se
.post
, &final_se
.finalblock
);
10912 sym
->backend_decl
= lhs
;
10914 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10916 if (expr1
->ts
.type
== BT_DERIVED
10917 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10919 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10921 gfc_add_expr_to_block (&se
.pre
, tmp
);
10924 se
.direct_byref
= 1;
10925 se
.ss
= gfc_walk_expr (expr2
);
10926 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10928 /* Since this is a direct by reference call, references to the lhs can be
10929 used for finalization of the function result just as long as the blocks
10930 from final_se are added at the right time. */
10931 gfc_init_se (&final_se
, NULL
);
10932 if (finalizable
&& expr2
->value
.function
.esym
)
10934 final_se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
10935 gfc_finalize_tree_expr (&final_se
, expr2
->ts
.u
.derived
,
10936 expr2
->value
.function
.esym
->attr
,
10940 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10941 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10942 Clearly, this cannot be done for an allocatable function result, since
10943 the shape of the result is unknown and, in any case, the function must
10944 correctly take care of the reallocation internally. For intrinsic
10945 calls, the array data is freed and the library takes care of allocation.
10946 TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
10948 if (flag_realloc_lhs
10949 && gfc_is_reallocatable_lhs (expr1
)
10950 && !gfc_expr_attr (expr1
).codimension
10951 && !gfc_is_coindexed (expr1
)
10952 && !(expr2
->value
.function
.esym
10953 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10955 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10957 if (!expr2
->value
.function
.isym
)
10959 ss
= gfc_walk_expr (expr1
);
10960 gcc_assert (ss
!= gfc_ss_terminator
);
10962 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10963 ss
->is_alloc_lhs
= 1;
10966 fcncall_realloc_result (&se
, expr1
->rank
);
10969 gfc_conv_function_expr (&se
, expr2
);
10971 /* Fix the result. */
10972 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10974 gfc_add_block_to_block (&se
.pre
, &final_se
.pre
);
10976 /* Do the finalization, including final calls from function arguments. */
10979 gfc_add_block_to_block (&se
.pre
, &final_se
.post
);
10980 gfc_add_block_to_block (&se
.pre
, &se
.finalblock
);
10981 gfc_add_block_to_block (&se
.pre
, &final_se
.finalblock
);
10985 gfc_cleanup_loop (&loop
);
10987 gfc_free_ss_chain (se
.ss
);
10989 return gfc_finish_block (&se
.pre
);
10993 /* Try to efficiently translate array(:) = 0. Return NULL if this
10997 gfc_trans_zero_assign (gfc_expr
* expr
)
10999 tree dest
, len
, type
;
11003 sym
= expr
->symtree
->n
.sym
;
11004 dest
= gfc_get_symbol_decl (sym
);
11006 type
= TREE_TYPE (dest
);
11007 if (POINTER_TYPE_P (type
))
11008 type
= TREE_TYPE (type
);
11009 if (!GFC_ARRAY_TYPE_P (type
))
11012 /* Determine the length of the array. */
11013 len
= GFC_TYPE_ARRAY_SIZE (type
);
11014 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
11017 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
11018 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
11019 fold_convert (gfc_array_index_type
, tmp
));
11021 /* If we are zeroing a local array avoid taking its address by emitting
11023 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
11024 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
11025 dest
, build_constructor (TREE_TYPE (dest
),
11028 /* Convert arguments to the correct types. */
11029 dest
= fold_convert (pvoid_type_node
, dest
);
11030 len
= fold_convert (size_type_node
, len
);
11032 /* Construct call to __builtin_memset. */
11033 tmp
= build_call_expr_loc (input_location
,
11034 builtin_decl_explicit (BUILT_IN_MEMSET
),
11035 3, dest
, integer_zero_node
, len
);
11036 return fold_convert (void_type_node
, tmp
);
11040 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
11041 that constructs the call to __builtin_memcpy. */
11044 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
11048 /* Convert arguments to the correct types. */
11049 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
11050 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
11052 dst
= fold_convert (pvoid_type_node
, dst
);
11054 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
11055 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
11057 src
= fold_convert (pvoid_type_node
, src
);
11059 len
= fold_convert (size_type_node
, len
);
11061 /* Construct call to __builtin_memcpy. */
11062 tmp
= build_call_expr_loc (input_location
,
11063 builtin_decl_explicit (BUILT_IN_MEMCPY
),
11065 return fold_convert (void_type_node
, tmp
);
11069 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
11070 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
11071 source/rhs, both are gfc_full_array_ref_p which have been checked for
11075 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
11077 tree dst
, dlen
, dtype
;
11078 tree src
, slen
, stype
;
11081 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
11082 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
11084 dtype
= TREE_TYPE (dst
);
11085 if (POINTER_TYPE_P (dtype
))
11086 dtype
= TREE_TYPE (dtype
);
11087 stype
= TREE_TYPE (src
);
11088 if (POINTER_TYPE_P (stype
))
11089 stype
= TREE_TYPE (stype
);
11091 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
11094 /* Determine the lengths of the arrays. */
11095 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
11096 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
11098 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
11099 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
11100 dlen
, fold_convert (gfc_array_index_type
, tmp
));
11102 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
11103 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
11105 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
11106 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
11107 slen
, fold_convert (gfc_array_index_type
, tmp
));
11109 /* Sanity check that they are the same. This should always be
11110 the case, as we should already have checked for conformance. */
11111 if (!tree_int_cst_equal (slen
, dlen
))
11114 return gfc_build_memcpy_call (dst
, src
, dlen
);
11118 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
11119 this can't be done. EXPR1 is the destination/lhs for which
11120 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
11123 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
11125 unsigned HOST_WIDE_INT nelem
;
11131 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
11135 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
11136 dtype
= TREE_TYPE (dst
);
11137 if (POINTER_TYPE_P (dtype
))
11138 dtype
= TREE_TYPE (dtype
);
11139 if (!GFC_ARRAY_TYPE_P (dtype
))
11142 /* Determine the lengths of the array. */
11143 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
11144 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
11147 /* Confirm that the constructor is the same size. */
11148 if (compare_tree_int (len
, nelem
) != 0)
11151 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
11152 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
11153 fold_convert (gfc_array_index_type
, tmp
));
11155 stype
= gfc_typenode_for_spec (&expr2
->ts
);
11156 src
= gfc_build_constant_array_constructor (expr2
, stype
);
11158 return gfc_build_memcpy_call (dst
, src
, len
);
11162 /* Tells whether the expression is to be treated as a variable reference. */
11165 gfc_expr_is_variable (gfc_expr
*expr
)
11168 gfc_component
*comp
;
11169 gfc_symbol
*func_ifc
;
11171 if (expr
->expr_type
== EXPR_VARIABLE
)
11174 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
11177 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
11178 return gfc_expr_is_variable (arg
);
11181 /* A data-pointer-returning function should be considered as a variable
11183 if (expr
->expr_type
== EXPR_FUNCTION
11184 && expr
->ref
== NULL
)
11186 if (expr
->value
.function
.isym
!= NULL
)
11189 if (expr
->value
.function
.esym
!= NULL
)
11191 func_ifc
= expr
->value
.function
.esym
;
11194 gcc_assert (expr
->symtree
);
11195 func_ifc
= expr
->symtree
->n
.sym
;
11199 comp
= gfc_get_proc_ptr_comp (expr
);
11200 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
11203 func_ifc
= comp
->ts
.interface
;
11207 if (expr
->expr_type
== EXPR_COMPCALL
)
11209 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
11210 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
11217 gcc_assert (func_ifc
->attr
.function
11218 && func_ifc
->result
!= NULL
);
11219 return func_ifc
->result
->attr
.pointer
;
11223 /* Is the lhs OK for automatic reallocation? */
11226 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
11230 /* An allocatable variable with no reference. */
11231 if (expr
->symtree
->n
.sym
->attr
.allocatable
11235 /* All that can be left are allocatable components. However, we do
11236 not check for allocatable components here because the expression
11237 could be an allocatable component of a pointer component. */
11238 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11239 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
11242 /* Find an allocatable component ref last. */
11243 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
11244 if (ref
->type
== REF_COMPONENT
11246 && ref
->u
.c
.component
->attr
.allocatable
)
11253 /* Allocate or reallocate scalar lhs, as necessary. */
11256 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
11257 tree string_length
,
11265 tree size_in_bytes
;
11271 if (!expr1
|| expr1
->rank
)
11274 if (!expr2
|| expr2
->rank
)
11277 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
11278 if (ref
->type
== REF_SUBSTRING
)
11281 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
11283 /* Since this is a scalar lhs, we can afford to do this. That is,
11284 there is no risk of side effects being repeated. */
11285 gfc_init_se (&lse
, NULL
);
11286 lse
.want_pointer
= 1;
11287 gfc_conv_expr (&lse
, expr1
);
11289 jump_label1
= gfc_build_label_decl (NULL_TREE
);
11290 jump_label2
= gfc_build_label_decl (NULL_TREE
);
11292 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
11293 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
11294 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
11296 tmp
= build3_v (COND_EXPR
, cond
,
11297 build1_v (GOTO_EXPR
, jump_label1
),
11298 build_empty_stmt (input_location
));
11299 gfc_add_expr_to_block (block
, tmp
);
11301 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11303 /* Use the rhs string length and the lhs element size. Note that 'size' is
11304 used below for the string-length comparison, only. */
11305 size
= string_length
;
11306 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr1
->ts
.kind
));
11307 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
11308 TREE_TYPE (tmp
), tmp
,
11309 fold_convert (TREE_TYPE (tmp
), size
));
11313 /* Otherwise use the length in bytes of the rhs. */
11314 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
11315 size_in_bytes
= size
;
11318 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
11319 size_in_bytes
, size_one_node
);
11321 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11323 tree caf_decl
, token
;
11325 symbol_attribute attr
;
11327 gfc_clear_attr (&attr
);
11328 gfc_init_se (&caf_se
, NULL
);
11330 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
11331 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11333 gfc_add_block_to_block (block
, &caf_se
.pre
);
11334 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
11335 gfc_build_addr_expr (NULL_TREE
, token
),
11336 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
11339 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
11341 tmp
= build_call_expr_loc (input_location
,
11342 builtin_decl_explicit (BUILT_IN_CALLOC
),
11343 2, build_one_cst (size_type_node
),
11345 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11346 gfc_add_modify (block
, lse
.expr
, tmp
);
11350 tmp
= build_call_expr_loc (input_location
,
11351 builtin_decl_explicit (BUILT_IN_MALLOC
),
11353 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11354 gfc_add_modify (block
, lse
.expr
, tmp
);
11357 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11359 /* Deferred characters need checking for lhs and rhs string
11360 length. Other deferred parameter variables will have to
11362 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
11363 gfc_add_expr_to_block (block
, tmp
);
11365 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
11366 gfc_add_expr_to_block (block
, tmp
);
11368 /* For a deferred length character, reallocate if lengths of lhs and
11369 rhs are different. */
11370 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11372 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
11374 fold_convert (TREE_TYPE (lse
.string_length
),
11376 /* Jump past the realloc if the lengths are the same. */
11377 tmp
= build3_v (COND_EXPR
, cond
,
11378 build1_v (GOTO_EXPR
, jump_label2
),
11379 build_empty_stmt (input_location
));
11380 gfc_add_expr_to_block (block
, tmp
);
11381 tmp
= build_call_expr_loc (input_location
,
11382 builtin_decl_explicit (BUILT_IN_REALLOC
),
11383 2, fold_convert (pvoid_type_node
, lse
.expr
),
11385 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11386 gfc_add_modify (block
, lse
.expr
, tmp
);
11387 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
11388 gfc_add_expr_to_block (block
, tmp
);
11390 /* Update the lhs character length. */
11391 size
= string_length
;
11392 gfc_add_modify (block
, lse
.string_length
,
11393 fold_convert (TREE_TYPE (lse
.string_length
), size
));
11397 /* Check for assignments of the type
11401 to make sure we do not check for reallocation unneccessarily. */
11405 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
11407 gfc_actual_arglist
*a
;
11410 switch (expr2
->expr_type
)
11412 case EXPR_VARIABLE
:
11413 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
11415 case EXPR_FUNCTION
:
11416 if (expr2
->value
.function
.esym
11417 && expr2
->value
.function
.esym
->attr
.elemental
)
11419 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
11422 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
11427 else if (expr2
->value
.function
.isym
11428 && expr2
->value
.function
.isym
->elemental
)
11430 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
11433 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
11442 switch (expr2
->value
.op
.op
)
11444 case INTRINSIC_NOT
:
11445 case INTRINSIC_UPLUS
:
11446 case INTRINSIC_UMINUS
:
11447 case INTRINSIC_PARENTHESES
:
11448 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
11450 case INTRINSIC_PLUS
:
11451 case INTRINSIC_MINUS
:
11452 case INTRINSIC_TIMES
:
11453 case INTRINSIC_DIVIDE
:
11454 case INTRINSIC_POWER
:
11455 case INTRINSIC_AND
:
11457 case INTRINSIC_EQV
:
11458 case INTRINSIC_NEQV
:
11465 case INTRINSIC_EQ_OS
:
11466 case INTRINSIC_NE_OS
:
11467 case INTRINSIC_GT_OS
:
11468 case INTRINSIC_GE_OS
:
11469 case INTRINSIC_LT_OS
:
11470 case INTRINSIC_LE_OS
:
11472 e1
= expr2
->value
.op
.op1
;
11473 e2
= expr2
->value
.op
.op2
;
11475 if (e1
->rank
== 0 && e2
->rank
> 0)
11476 return is_runtime_conformable (expr1
, e2
);
11477 else if (e1
->rank
> 0 && e2
->rank
== 0)
11478 return is_runtime_conformable (expr1
, e1
);
11479 else if (e1
->rank
> 0 && e2
->rank
> 0)
11480 return is_runtime_conformable (expr1
, e1
)
11481 && is_runtime_conformable (expr1
, e2
);
11499 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
11500 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
11501 bool class_realloc
)
11503 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
, old_vptr
;
11504 vec
<tree
, va_gc
> *args
= NULL
;
11507 final_expr
= gfc_assignment_finalizer_call (lse
, lhs
, false);
11511 gfc_prepend_expr_to_block (&rse
->loop
->pre
,
11512 gfc_finish_block (&lse
->finalblock
));
11514 gfc_add_block_to_block (block
, &lse
->finalblock
);
11517 /* Store the old vptr so that dynamic types can be compared for
11518 reallocation to occur or not. */
11522 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
11523 tmp
= gfc_get_class_from_expr (tmp
);
11526 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
11529 /* Generate (re)allocation of the lhs. */
11532 stmtblock_t alloc
, re_alloc
;
11533 tree class_han
, re
, size
;
11535 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
11536 old_vptr
= gfc_evaluate_now (gfc_class_vptr_get (tmp
), block
);
11538 old_vptr
= build_int_cst (TREE_TYPE (vptr
), 0);
11540 size
= gfc_vptr_size_get (vptr
);
11542 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
11543 ? gfc_class_data_get (tmp
) : tmp
;
11545 if (!POINTER_TYPE_P (TREE_TYPE (class_han
)))
11546 class_han
= gfc_build_addr_expr (NULL_TREE
, class_han
);
11548 /* Allocate block. */
11549 gfc_init_block (&alloc
);
11550 gfc_allocate_using_malloc (&alloc
, class_han
, size
, NULL_TREE
);
11552 /* Reallocate if dynamic types are different. */
11553 gfc_init_block (&re_alloc
);
11554 re
= build_call_expr_loc (input_location
,
11555 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
11556 fold_convert (pvoid_type_node
, class_han
),
11558 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
11559 logical_type_node
, vptr
, old_vptr
);
11560 re
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
11561 tmp
, re
, build_empty_stmt (input_location
));
11562 gfc_add_expr_to_block (&re_alloc
, re
);
11564 tree realloc_expr
= lhs
->ts
.type
== BT_CLASS
?
11565 gfc_finish_block (&re_alloc
) :
11566 build_empty_stmt (input_location
);
11568 /* Allocate if _data is NULL, reallocate otherwise. */
11569 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
11570 logical_type_node
, class_han
,
11571 build_int_cst (prvoid_type_node
, 0));
11572 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
11574 PRED_FORTRAN_FAIL_ALLOC
),
11575 gfc_finish_block (&alloc
),
11577 gfc_add_expr_to_block (&lse
->pre
, tmp
);
11580 fcn
= gfc_vptr_copy_get (vptr
);
11582 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
11583 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
11586 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
11587 || INDIRECT_REF_P (tmp
)
11588 || (rhs
->ts
.type
== BT_DERIVED
11589 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
11590 && !rhs
->ts
.u
.derived
->attr
.pointer
11591 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
11592 || (UNLIMITED_POLY (rhs
)
11593 && !CLASS_DATA (rhs
)->attr
.pointer
11594 && !CLASS_DATA (rhs
)->attr
.allocatable
))
11595 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
11597 vec_safe_push (args
, tmp
);
11598 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
11599 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
11600 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
11601 || INDIRECT_REF_P (tmp
)
11602 || (lhs
->ts
.type
== BT_DERIVED
11603 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
11604 && !lhs
->ts
.u
.derived
->attr
.pointer
11605 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
11606 || (UNLIMITED_POLY (lhs
)
11607 && !CLASS_DATA (lhs
)->attr
.pointer
11608 && !CLASS_DATA (lhs
)->attr
.allocatable
))
11609 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
11611 vec_safe_push (args
, tmp
);
11613 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
11615 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
11618 vec_safe_push (args
, from_len
);
11619 vec_safe_push (args
, to_len
);
11620 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
11622 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
11623 logical_type_node
, from_len
,
11624 build_zero_cst (TREE_TYPE (from_len
)));
11625 return fold_build3_loc (input_location
, COND_EXPR
,
11626 void_type_node
, tmp
,
11634 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
11635 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
11636 stmtblock_t tblock
;
11637 gfc_init_block (&tblock
);
11638 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
11639 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11640 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
11641 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
11642 /* When coming from a ptr_copy lhs and rhs are swapped. */
11643 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
11644 fold_convert (TREE_TYPE (rhst
), tmp
));
11645 return gfc_finish_block (&tblock
);
11650 /* Subroutine of gfc_trans_assignment that actually scalarizes the
11651 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11652 init_flag indicates initialization expressions and dealloc that no
11653 deallocate prior assignment is needed (if in doubt, set true).
11654 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11655 routine instead of a pointer assignment. Alias resolution is only done,
11656 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11657 where it is known, that newly allocated memory on the lhs can never be
11658 an alias of the rhs. */
11661 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11662 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11667 gfc_ss
*lss_section
;
11675 bool scalar_to_array
;
11676 tree string_length
;
11678 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
11679 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
11680 bool is_poly_assign
;
11683 /* Assignment of the form lhs = rhs. */
11684 gfc_start_block (&block
);
11686 gfc_init_se (&lse
, NULL
);
11687 gfc_init_se (&rse
, NULL
);
11689 /* Walk the lhs. */
11690 lss
= gfc_walk_expr (expr1
);
11691 if (gfc_is_reallocatable_lhs (expr1
))
11693 lss
->no_bounds_check
= 1;
11694 if (!(expr2
->expr_type
== EXPR_FUNCTION
11695 && expr2
->value
.function
.isym
!= NULL
11696 && !(expr2
->value
.function
.isym
->elemental
11697 || expr2
->value
.function
.isym
->conversion
)))
11698 lss
->is_alloc_lhs
= 1;
11701 lss
->no_bounds_check
= expr1
->no_bounds_check
;
11705 if (expr2
->expr_type
!= EXPR_VARIABLE
11706 && expr2
->expr_type
!= EXPR_CONSTANT
11707 && (expr2
->ts
.type
== BT_CLASS
|| gfc_may_be_finalized (expr2
->ts
)))
11709 expr2
->must_finalize
= 1;
11710 /* F2008 4.5.6.3 para 5: If an executable construct references a
11711 structure constructor or array constructor, the entity created by
11712 the constructor is finalized after execution of the innermost
11713 executable construct containing the reference.
11714 These finalizations were later deleted by the Combined Techical
11715 Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
11716 if (gfc_notification_std (GFC_STD_F2018_DEL
)
11717 && (expr2
->expr_type
== EXPR_STRUCTURE
11718 || expr2
->expr_type
== EXPR_ARRAY
))
11719 expr2
->must_finalize
= 0;
11723 /* Checking whether a class assignment is desired is quite complicated and
11724 needed at two locations, so do it once only before the information is
11726 lhs_attr
= gfc_expr_attr (expr1
);
11728 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
11729 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
11730 && (expr1
->ts
.type
== BT_CLASS
11731 || gfc_is_class_array_ref (expr1
, NULL
)
11732 || gfc_is_class_scalar_expr (expr1
)
11733 || gfc_is_class_array_ref (expr2
, NULL
)
11734 || gfc_is_class_scalar_expr (expr2
))
11735 && lhs_attr
.flavor
!= FL_PROCEDURE
;
11737 realloc_flag
= flag_realloc_lhs
11738 && gfc_is_reallocatable_lhs (expr1
)
11740 && !is_runtime_conformable (expr1
, expr2
);
11742 /* Only analyze the expressions for coarray properties, when in coarray-lib
11744 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11746 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
11747 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
11750 if (lss
!= gfc_ss_terminator
)
11752 /* The assignment needs scalarization. */
11755 /* Find a non-scalar SS from the lhs. */
11756 while (lss_section
!= gfc_ss_terminator
11757 && lss_section
->info
->type
!= GFC_SS_SECTION
)
11758 lss_section
= lss_section
->next
;
11760 gcc_assert (lss_section
!= gfc_ss_terminator
);
11762 /* Initialize the scalarizer. */
11763 gfc_init_loopinfo (&loop
);
11765 /* Walk the rhs. */
11766 rss
= gfc_walk_expr (expr2
);
11767 if (rss
== gfc_ss_terminator
)
11768 /* The rhs is scalar. Add a ss for the expression. */
11769 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
11770 /* When doing a class assign, then the handle to the rhs needs to be a
11771 pointer to allow for polymorphism. */
11772 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
11773 rss
->info
->type
= GFC_SS_REFERENCE
;
11775 rss
->no_bounds_check
= expr2
->no_bounds_check
;
11776 /* Associate the SS with the loop. */
11777 gfc_add_ss_to_loop (&loop
, lss
);
11778 gfc_add_ss_to_loop (&loop
, rss
);
11780 /* Calculate the bounds of the scalarization. */
11781 gfc_conv_ss_startstride (&loop
);
11782 /* Enable loop reversal. */
11783 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
11784 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
11785 /* Resolve any data dependencies in the statement. */
11787 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
11788 /* Setup the scalarizing loops. */
11789 gfc_conv_loop_setup (&loop
, &expr2
->where
);
11791 /* Setup the gfc_se structures. */
11792 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11793 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11796 gfc_mark_ss_chain_used (rss
, 1);
11797 if (loop
.temp_ss
== NULL
)
11800 gfc_mark_ss_chain_used (lss
, 1);
11804 lse
.ss
= loop
.temp_ss
;
11805 gfc_mark_ss_chain_used (lss
, 3);
11806 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
11809 /* Allow the scalarizer to workshare array assignments. */
11810 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
11811 == OMPWS_WORKSHARE_FLAG
11812 && loop
.temp_ss
== NULL
)
11814 maybe_workshare
= true;
11815 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
11818 /* Start the scalarized loop body. */
11819 gfc_start_scalarized_body (&loop
, &body
);
11822 gfc_init_block (&body
);
11824 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
11826 /* Translate the expression. */
11827 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
11828 && lhs_caf_attr
.codimension
;
11829 gfc_conv_expr (&rse
, expr2
);
11831 /* Deal with the case of a scalar class function assigned to a derived type. */
11832 if (gfc_is_alloc_class_scalar_function (expr2
)
11833 && expr1
->ts
.type
== BT_DERIVED
)
11835 rse
.expr
= gfc_class_data_get (rse
.expr
);
11836 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
11839 /* Stabilize a string length for temporaries. */
11840 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
11841 && !(VAR_P (rse
.string_length
)
11842 || TREE_CODE (rse
.string_length
) == PARM_DECL
11843 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
11844 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
11845 else if (expr2
->ts
.type
== BT_CHARACTER
)
11847 if (expr1
->ts
.deferred
11848 && gfc_expr_attr (expr1
).allocatable
11849 && gfc_check_dependency (expr1
, expr2
, true))
11850 rse
.string_length
=
11851 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
11852 string_length
= rse
.string_length
;
11855 string_length
= NULL_TREE
;
11859 gfc_conv_tmp_array_ref (&lse
);
11860 if (expr2
->ts
.type
== BT_CHARACTER
)
11861 lse
.string_length
= string_length
;
11865 gfc_conv_expr (&lse
, expr1
);
11866 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
11868 && gfc_expr_attr (expr1
).allocatable
11875 tmp
= INDIRECT_REF_P (lse
.expr
)
11876 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
11879 /* We should only get array references here. */
11880 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
11881 || TREE_CODE (tmp
) == ARRAY_REF
);
11883 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
11884 or the array itself(ARRAY_REF). */
11885 tmp
= TREE_OPERAND (tmp
, 0);
11887 /* Provide the address of the array. */
11888 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
11889 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11891 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
11892 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
11893 msg
= _("Assignment of scalar to unallocated array");
11894 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
11895 &expr1
->where
, msg
);
11898 /* Deallocate the lhs parameterized components if required. */
11899 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
11900 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
11902 if (expr1
->ts
.type
== BT_DERIVED
11903 && expr1
->ts
.u
.derived
11904 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
11906 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
11908 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11910 else if (expr1
->ts
.type
== BT_CLASS
11911 && CLASS_DATA (expr1
)->ts
.u
.derived
11912 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
11914 tmp
= gfc_class_data_get (lse
.expr
);
11915 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
11917 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11922 /* Assignments of scalar derived types with allocatable components
11923 to arrays must be done with a deep copy and the rhs temporary
11924 must have its components deallocated afterwards. */
11925 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
11926 && expr2
->ts
.u
.derived
->attr
.alloc_comp
11927 && !gfc_expr_is_variable (expr2
)
11928 && expr1
->rank
&& !expr2
->rank
);
11929 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
11931 && expr1
->ts
.u
.derived
->attr
.alloc_comp
11932 && gfc_is_alloc_class_scalar_function (expr2
));
11933 if (scalar_to_array
&& dealloc
)
11935 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
11936 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
11939 /* When assigning a character function result to a deferred-length variable,
11940 the function call must happen before the (re)allocation of the lhs -
11941 otherwise the character length of the result is not known.
11942 NOTE 1: This relies on having the exact dependence of the length type
11943 parameter available to the caller; gfortran saves it in the .mod files.
11944 NOTE 2: Vector array references generate an index temporary that must
11945 not go outside the loop. Otherwise, variables should not generate
11947 NOTE 3: The concatenation operation generates a temporary pointer,
11948 whose allocation must go to the innermost loop.
11949 NOTE 4: Elemental functions may generate a temporary, too. */
11950 if (flag_realloc_lhs
11951 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
11952 && !(lss
!= gfc_ss_terminator
11953 && rss
!= gfc_ss_terminator
11954 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
11955 || (expr2
->expr_type
== EXPR_FUNCTION
11956 && expr2
->value
.function
.esym
!= NULL
11957 && expr2
->value
.function
.esym
->attr
.elemental
)
11958 || (expr2
->expr_type
== EXPR_FUNCTION
11959 && expr2
->value
.function
.isym
!= NULL
11960 && expr2
->value
.function
.isym
->elemental
)
11961 || (expr2
->expr_type
== EXPR_OP
11962 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
11963 gfc_add_block_to_block (&block
, &rse
.pre
);
11965 /* Nullify the allocatable components corresponding to those of the lhs
11966 derived type, so that the finalization of the function result does not
11967 affect the lhs of the assignment. Prepend is used to ensure that the
11968 nullification occurs before the call to the finalizer. In the case of
11969 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11970 as part of the deep copy. */
11971 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11972 && (gfc_is_class_array_function (expr2
)
11973 || gfc_is_alloc_class_scalar_function (expr2
)))
11975 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11976 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11977 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11978 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11983 if (is_poly_assign
)
11985 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11986 use_vptr_copy
|| (lhs_attr
.allocatable
11987 && !lhs_attr
.dimension
),
11988 !realloc_flag
&& flag_realloc_lhs
11989 && !lhs_attr
.pointer
);
11990 if (expr2
->expr_type
== EXPR_FUNCTION
11991 && expr2
->ts
.type
== BT_DERIVED
11992 && expr2
->ts
.u
.derived
->attr
.alloc_comp
)
11994 tree tmp2
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
,
11995 rse
.expr
, expr2
->rank
);
11996 if (lss
== gfc_ss_terminator
)
11997 gfc_add_expr_to_block (&rse
.post
, tmp2
);
11999 gfc_add_expr_to_block (&loop
.post
, tmp2
);
12002 expr1
->must_finalize
= 0;
12004 else if (flag_coarray
== GFC_FCOARRAY_LIB
12005 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
12006 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
12007 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
12009 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
12010 allocatable component, because those need to be accessed via the
12011 caf-runtime. No need to check for coindexes here, because resolve
12012 has rewritten those already. */
12014 gfc_actual_arglist a1
, a2
;
12015 /* Clear the structures to prevent accessing garbage. */
12016 memset (&code
, '\0', sizeof (gfc_code
));
12017 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
12018 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
12023 code
.ext
.actual
= &a1
;
12024 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
12025 tmp
= gfc_conv_intrinsic_subroutine (&code
);
12027 else if (!is_poly_assign
&& expr2
->must_finalize
12028 && expr1
->ts
.type
== BT_CLASS
12029 && expr2
->ts
.type
== BT_CLASS
)
12031 /* This case comes about when the scalarizer provides array element
12032 references. Use the vptr copy function, since this does a deep
12033 copy of allocatable components, without which the finalizer call
12034 will deallocate the components. */
12035 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
12036 if (tmp
!= NULL_TREE
)
12038 tree fcn
= gfc_vptr_copy_get (tmp
);
12039 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
12040 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
12041 tmp
= build_call_expr_loc (input_location
,
12043 gfc_build_addr_expr (NULL
, rse
.expr
),
12044 gfc_build_addr_expr (NULL
, lse
.expr
));
12048 /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
12049 after evaluation of the rhs and before reallocation. */
12050 final_expr
= gfc_assignment_finalizer_call (&lse
, expr1
, init_flag
);
12051 if (final_expr
&& !(expr2
->expr_type
== EXPR_VARIABLE
12052 && expr2
->symtree
->n
.sym
->attr
.artificial
))
12054 if (lss
== gfc_ss_terminator
)
12056 gfc_add_block_to_block (&block
, &rse
.pre
);
12057 gfc_add_block_to_block (&block
, &lse
.finalblock
);
12061 gfc_add_block_to_block (&body
, &rse
.pre
);
12062 gfc_add_block_to_block (&loop
.code
[expr1
->rank
- 1],
12067 gfc_add_block_to_block (&body
, &rse
.pre
);
12069 /* If nothing else works, do it the old fashioned way! */
12070 if (tmp
== NULL_TREE
)
12071 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
12072 gfc_expr_is_variable (expr2
)
12074 || expr2
->expr_type
== EXPR_ARRAY
,
12075 !(l_is_temp
|| init_flag
) && dealloc
,
12076 expr1
->symtree
->n
.sym
->attr
.codimension
);
12079 /* Add the lse pre block to the body */
12080 gfc_add_block_to_block (&body
, &lse
.pre
);
12081 gfc_add_expr_to_block (&body
, tmp
);
12083 /* Add the post blocks to the body. */
12086 gfc_add_block_to_block (&rse
.finalblock
, &rse
.post
);
12087 gfc_add_block_to_block (&body
, &rse
.finalblock
);
12090 gfc_add_block_to_block (&body
, &rse
.post
);
12092 gfc_add_block_to_block (&body
, &lse
.post
);
12094 if (lss
== gfc_ss_terminator
)
12096 /* F2003: Add the code for reallocation on assignment. */
12097 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
12098 && !is_poly_assign
)
12099 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
12102 /* Use the scalar assignment as is. */
12103 gfc_add_block_to_block (&block
, &body
);
12107 gcc_assert (lse
.ss
== gfc_ss_terminator
12108 && rse
.ss
== gfc_ss_terminator
);
12112 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
12114 /* We need to copy the temporary to the actual lhs. */
12115 gfc_init_se (&lse
, NULL
);
12116 gfc_init_se (&rse
, NULL
);
12117 gfc_copy_loopinfo_to_se (&lse
, &loop
);
12118 gfc_copy_loopinfo_to_se (&rse
, &loop
);
12120 rse
.ss
= loop
.temp_ss
;
12123 gfc_conv_tmp_array_ref (&rse
);
12124 gfc_conv_expr (&lse
, expr1
);
12126 gcc_assert (lse
.ss
== gfc_ss_terminator
12127 && rse
.ss
== gfc_ss_terminator
);
12129 if (expr2
->ts
.type
== BT_CHARACTER
)
12130 rse
.string_length
= string_length
;
12132 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
12134 gfc_add_expr_to_block (&body
, tmp
);
12137 /* F2003: Allocate or reallocate lhs of allocatable array. */
12140 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
12141 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
12142 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
12143 if (tmp
!= NULL_TREE
)
12144 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
12147 if (maybe_workshare
)
12148 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
12150 /* Generate the copying loops. */
12151 gfc_trans_scalarizing_loops (&loop
, &body
);
12153 /* Wrap the whole thing up. */
12154 gfc_add_block_to_block (&block
, &loop
.pre
);
12155 gfc_add_block_to_block (&block
, &loop
.post
);
12157 gfc_cleanup_loop (&loop
);
12160 return gfc_finish_block (&block
);
12164 /* Check whether EXPR is a copyable array. */
12167 copyable_array_p (gfc_expr
* expr
)
12169 if (expr
->expr_type
!= EXPR_VARIABLE
)
12172 /* First check it's an array. */
12173 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
12176 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
12179 /* Next check that it's of a simple enough type. */
12180 switch (expr
->ts
.type
)
12192 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
12201 /* Translate an assignment. */
12204 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
12205 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
12209 /* Special case a single function returning an array. */
12210 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
12212 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
12217 /* Special case assigning an array to zero. */
12218 if (copyable_array_p (expr1
)
12219 && is_zero_initializer_p (expr2
))
12221 tmp
= gfc_trans_zero_assign (expr1
);
12226 /* Special case copying one array to another. */
12227 if (copyable_array_p (expr1
)
12228 && copyable_array_p (expr2
)
12229 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
12230 && !gfc_check_dependency (expr1
, expr2
, 0))
12232 tmp
= gfc_trans_array_copy (expr1
, expr2
);
12237 /* Special case initializing an array from a constant array constructor. */
12238 if (copyable_array_p (expr1
)
12239 && expr2
->expr_type
== EXPR_ARRAY
12240 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
12242 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
12247 if (UNLIMITED_POLY (expr1
) && expr1
->rank
)
12248 use_vptr_copy
= true;
12250 /* Fallback to the scalarizer to generate explicit loops. */
12251 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
12252 use_vptr_copy
, may_alias
);
12256 gfc_trans_init_assign (gfc_code
* code
)
12258 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
12262 gfc_trans_assign (gfc_code
* code
)
12264 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
12267 /* Generate a simple loop for internal use of the form
12268 for (var = begin; var <cond> end; var += step)
12271 gfc_simple_for_loop (stmtblock_t
*block
, tree var
, tree begin
, tree end
,
12272 enum tree_code cond
, tree step
, tree body
)
12277 gfc_add_modify (block
, var
, begin
);
12279 /* Loop: for (var = begin; var <cond> end; var += step). */
12280 tree label_loop
= gfc_build_label_decl (NULL_TREE
);
12281 tree label_cond
= gfc_build_label_decl (NULL_TREE
);
12282 TREE_USED (label_loop
) = 1;
12283 TREE_USED (label_cond
) = 1;
12285 gfc_add_expr_to_block (block
, build1_v (GOTO_EXPR
, label_cond
));
12286 gfc_add_expr_to_block (block
, build1_v (LABEL_EXPR
, label_loop
));
12289 gfc_add_expr_to_block (block
, body
);
12291 /* End of loop body. */
12292 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
12293 gfc_add_modify (block
, var
, tmp
);
12294 gfc_add_expr_to_block (block
, build1_v (LABEL_EXPR
, label_cond
));
12295 tmp
= fold_build2_loc (input_location
, cond
, boolean_type_node
, var
, end
);
12296 tmp
= build3_v (COND_EXPR
, tmp
, build1_v (GOTO_EXPR
, label_loop
),
12297 build_empty_stmt (input_location
));
12298 gfc_add_expr_to_block (block
, tmp
);