1 /* Expression translation
2 Copyright (C) 2002-2021 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
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.c: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.c: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. */
1181 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
1182 && gfc_expr_attr (e
).dimension
)
1185 gfc_is_class_array_ref (e
, &full_array
);
1187 /* The derived type needs to be converted to a temporary
1189 tmp
= gfc_typenode_for_spec (&class_ts
);
1190 var
= gfc_create_var (tmp
, "class");
1193 ctree
= gfc_class_data_get (var
);
1194 if (class_ts
.u
.derived
->components
->as
1195 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1199 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1201 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1202 gfc_get_dtype (type
));
1204 tmp
= gfc_class_data_get (parmse
->expr
);
1205 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1206 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1208 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1211 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1215 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1216 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1217 TREE_TYPE (ctree
), parmse
->expr
);
1218 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1221 /* Return the data component, except in the case of scalarized array
1222 references, where nullification of the cannot occur and so there
1224 if (!elemental
&& full_array
&& copyback
)
1226 if (class_ts
.u
.derived
->components
->as
1227 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1230 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1231 gfc_conv_descriptor_data_get (ctree
));
1233 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1236 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1240 ctree
= gfc_class_vptr_get (var
);
1242 /* The vptr is the second field of the actual argument.
1243 First we have to find the corresponding class reference. */
1246 if (gfc_is_class_array_function (e
)
1247 && parmse
->class_vptr
!= NULL_TREE
)
1248 tmp
= parmse
->class_vptr
;
1249 else if (class_ref
== NULL
1250 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1252 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1254 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1255 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1257 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1258 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1260 slen
= build_zero_cst (size_type_node
);
1264 /* Remove everything after the last class reference, convert the
1265 expression and then recover its tailend once more. */
1267 ref
= class_ref
->next
;
1268 class_ref
->next
= NULL
;
1269 gfc_init_se (&tmpse
, NULL
);
1270 gfc_conv_expr (&tmpse
, e
);
1271 class_ref
->next
= ref
;
1273 slen
= tmpse
.string_length
;
1276 gcc_assert (tmp
!= NULL_TREE
);
1278 /* Dereference if needs be. */
1279 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1280 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1282 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1283 vptr
= gfc_class_vptr_get (tmp
);
1287 gfc_add_modify (&block
, ctree
,
1288 fold_convert (TREE_TYPE (ctree
), vptr
));
1290 /* Return the vptr component, except in the case of scalarized array
1291 references, where the dynamic type cannot change. */
1292 if (!elemental
&& full_array
&& copyback
)
1293 gfc_add_modify (&parmse
->post
, vptr
,
1294 fold_convert (TREE_TYPE (vptr
), ctree
));
1296 /* For unlimited polymorphic objects also set the _len component. */
1297 if (class_ts
.type
== BT_CLASS
1298 && class_ts
.u
.derived
->components
1299 && class_ts
.u
.derived
->components
->ts
.u
1300 .derived
->attr
.unlimited_polymorphic
)
1302 ctree
= gfc_class_len_get (var
);
1303 if (UNLIMITED_POLY (e
))
1304 tmp
= gfc_class_len_get (tmp
);
1305 else if (e
->ts
.type
== BT_CHARACTER
)
1307 gcc_assert (slen
!= NULL_TREE
);
1311 tmp
= build_zero_cst (size_type_node
);
1312 gfc_add_modify (&parmse
->pre
, ctree
,
1313 fold_convert (TREE_TYPE (ctree
), tmp
));
1315 /* Return the len component, except in the case of scalarized array
1316 references, where the dynamic type cannot change. */
1317 if (!elemental
&& full_array
&& copyback
1318 && (UNLIMITED_POLY (e
) || VAR_P (tmp
)))
1319 gfc_add_modify (&parmse
->post
, tmp
,
1320 fold_convert (TREE_TYPE (tmp
), ctree
));
1327 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1328 /* parmse->pre may contain some preparatory instructions for the
1329 temporary array descriptor. Those may only be executed when the
1330 optional argument is set, therefore add parmse->pre's instructions
1331 to block, which is later guarded by an if (optional_arg_given). */
1332 gfc_add_block_to_block (&parmse
->pre
, &block
);
1333 block
.head
= parmse
->pre
.head
;
1334 parmse
->pre
.head
= NULL_TREE
;
1335 tmp
= gfc_finish_block (&block
);
1337 if (optional_alloc_ptr
)
1338 tmp2
= build_empty_stmt (input_location
);
1341 gfc_init_block (&block
);
1343 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1344 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1345 null_pointer_node
));
1346 tmp2
= gfc_finish_block (&block
);
1349 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1351 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1354 gfc_add_block_to_block (&parmse
->pre
, &block
);
1356 /* Pass the address of the class object. */
1357 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1359 if (optional
&& optional_alloc_ptr
)
1360 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1361 TREE_TYPE (parmse
->expr
),
1363 fold_convert (TREE_TYPE (parmse
->expr
),
1364 null_pointer_node
));
1368 /* Given a class array declaration and an index, returns the address
1369 of the referenced element. */
1372 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
,
1375 tree data
, size
, tmp
, ctmp
, offset
, ptr
;
1377 data
= data_comp
!= NULL_TREE
? data_comp
:
1378 gfc_class_data_get (class_decl
);
1379 size
= gfc_class_vtab_size_get (class_decl
);
1383 tmp
= fold_convert (gfc_array_index_type
,
1384 gfc_class_len_get (class_decl
));
1385 ctmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1386 gfc_array_index_type
, size
, tmp
);
1387 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1388 logical_type_node
, tmp
,
1389 build_zero_cst (TREE_TYPE (tmp
)));
1390 size
= fold_build3_loc (input_location
, COND_EXPR
,
1391 gfc_array_index_type
, tmp
, ctmp
, size
);
1394 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1395 gfc_array_index_type
,
1398 data
= gfc_conv_descriptor_data_get (data
);
1399 ptr
= fold_convert (pvoid_type_node
, data
);
1400 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1401 return fold_convert (TREE_TYPE (data
), ptr
);
1405 /* Copies one class expression to another, assuming that if either
1406 'to' or 'from' are arrays they are packed. Should 'from' be
1407 NULL_TREE, the initialization expression for 'to' is used, assuming
1408 that the _vptr is set. */
1411 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1421 vec
<tree
, va_gc
> *args
;
1426 bool is_from_desc
= false, is_to_class
= false;
1429 /* To prevent warnings on uninitialized variables. */
1430 from_len
= to_len
= NULL_TREE
;
1432 if (from
!= NULL_TREE
)
1433 fcn
= gfc_class_vtab_copy_get (from
);
1435 fcn
= gfc_class_vtab_copy_get (to
);
1437 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1439 if (from
!= NULL_TREE
)
1441 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1445 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1449 /* Check that from is a class. When the class is part of a coarray,
1450 then from is a common pointer and is to be used as is. */
1451 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1452 ? build_fold_indirect_ref (from
) : from
;
1454 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1455 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1456 ? gfc_class_data_get (from
) : from
;
1457 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1461 from_data
= gfc_class_vtab_def_init_get (to
);
1465 if (from
!= NULL_TREE
&& unlimited
)
1466 from_len
= gfc_class_len_or_zero_get (from
);
1468 from_len
= build_zero_cst (size_type_node
);
1471 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1474 to_data
= gfc_class_data_get (to
);
1476 to_len
= gfc_class_len_get (to
);
1479 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1482 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1484 stmtblock_t loopbody
;
1488 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1490 gfc_init_block (&body
);
1491 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1492 gfc_array_index_type
, nelems
,
1493 gfc_index_one_node
);
1494 nelems
= gfc_evaluate_now (tmp
, &body
);
1495 index
= gfc_create_var (gfc_array_index_type
, "S");
1499 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
,
1501 vec_safe_push (args
, from_ref
);
1504 vec_safe_push (args
, from_data
);
1507 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
, unlimited
);
1510 tmp
= gfc_conv_array_data (to
);
1511 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1512 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1513 gfc_build_array_ref (tmp
, index
, to
));
1515 vec_safe_push (args
, to_ref
);
1517 /* Add bounds check. */
1518 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1521 const char *name
= "<<unknown>>";
1525 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1527 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1528 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1529 logical_type_node
, from_len
, orig_nelems
);
1530 msg
= xasprintf ("Array bound mismatch for dimension %d "
1531 "of array '%s' (%%ld/%%ld)",
1534 gfc_trans_runtime_check (true, false, tmp
, &body
,
1535 &gfc_current_locus
, msg
,
1536 fold_convert (long_integer_type_node
, orig_nelems
),
1537 fold_convert (long_integer_type_node
, from_len
));
1542 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1544 /* Build the body of the loop. */
1545 gfc_init_block (&loopbody
);
1546 gfc_add_expr_to_block (&loopbody
, tmp
);
1548 /* Build the loop and return. */
1549 gfc_init_loopinfo (&loop
);
1551 loop
.from
[0] = gfc_index_zero_node
;
1552 loop
.loopvar
[0] = index
;
1553 loop
.to
[0] = nelems
;
1554 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1555 gfc_init_block (&ifbody
);
1556 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1557 stdcopy
= gfc_finish_block (&ifbody
);
1558 /* In initialization mode from_len is a constant zero. */
1559 if (unlimited
&& !integer_zerop (from_len
))
1561 vec_safe_push (args
, from_len
);
1562 vec_safe_push (args
, to_len
);
1563 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1564 /* Build the body of the loop. */
1565 gfc_init_block (&loopbody
);
1566 gfc_add_expr_to_block (&loopbody
, tmp
);
1568 /* Build the loop and return. */
1569 gfc_init_loopinfo (&loop
);
1571 loop
.from
[0] = gfc_index_zero_node
;
1572 loop
.loopvar
[0] = index
;
1573 loop
.to
[0] = nelems
;
1574 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1575 gfc_init_block (&ifbody
);
1576 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1577 extcopy
= gfc_finish_block (&ifbody
);
1579 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1580 logical_type_node
, from_len
,
1581 build_zero_cst (TREE_TYPE (from_len
)));
1582 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1583 void_type_node
, tmp
, extcopy
, stdcopy
);
1584 gfc_add_expr_to_block (&body
, tmp
);
1585 tmp
= gfc_finish_block (&body
);
1589 gfc_add_expr_to_block (&body
, stdcopy
);
1590 tmp
= gfc_finish_block (&body
);
1592 gfc_cleanup_loop (&loop
);
1596 gcc_assert (!is_from_desc
);
1597 vec_safe_push (args
, from_data
);
1598 vec_safe_push (args
, to_data
);
1599 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1601 /* In initialization mode from_len is a constant zero. */
1602 if (unlimited
&& !integer_zerop (from_len
))
1604 vec_safe_push (args
, from_len
);
1605 vec_safe_push (args
, to_len
);
1606 extcopy
= build_call_vec (fcn_type
, unshare_expr (fcn
), args
);
1607 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1608 logical_type_node
, from_len
,
1609 build_zero_cst (TREE_TYPE (from_len
)));
1610 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1611 void_type_node
, tmp
, extcopy
, stdcopy
);
1617 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1618 if (from
== NULL_TREE
)
1621 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1623 from_data
, null_pointer_node
);
1624 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1625 void_type_node
, cond
,
1626 tmp
, build_empty_stmt (input_location
));
1634 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1636 gfc_actual_arglist
*actual
;
1641 actual
= gfc_get_actual_arglist ();
1642 actual
->expr
= gfc_copy_expr (rhs
);
1643 actual
->next
= gfc_get_actual_arglist ();
1644 actual
->next
->expr
= gfc_copy_expr (lhs
);
1645 ppc
= gfc_copy_expr (obj
);
1646 gfc_add_vptr_component (ppc
);
1647 gfc_add_component_ref (ppc
, "_copy");
1648 ppc_code
= gfc_get_code (EXEC_CALL
);
1649 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1650 /* Although '_copy' is set to be elemental in class.c, it is
1651 not staying that way. Find out why, sometime.... */
1652 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1653 ppc_code
->ext
.actual
= actual
;
1654 ppc_code
->expr1
= ppc
;
1655 /* Since '_copy' is elemental, the scalarizer will take care
1656 of arrays in gfc_trans_call. */
1657 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1658 gfc_free_statements (ppc_code
);
1660 if (UNLIMITED_POLY(obj
))
1662 /* Check if rhs is non-NULL. */
1664 gfc_init_se (&src
, NULL
);
1665 gfc_conv_expr (&src
, rhs
);
1666 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1667 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1668 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1669 null_pointer_node
));
1670 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1671 build_empty_stmt (input_location
));
1677 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1678 A MEMCPY is needed to copy the full data from the default initializer
1679 of the dynamic type. */
1682 gfc_trans_class_init_assign (gfc_code
*code
)
1686 gfc_se dst
,src
,memsz
;
1687 gfc_expr
*lhs
, *rhs
, *sz
;
1689 gfc_start_block (&block
);
1691 lhs
= gfc_copy_expr (code
->expr1
);
1693 rhs
= gfc_copy_expr (code
->expr1
);
1694 gfc_add_vptr_component (rhs
);
1696 /* Make sure that the component backend_decls have been built, which
1697 will not have happened if the derived types concerned have not
1699 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1700 gfc_add_def_init_component (rhs
);
1701 /* The _def_init is always scalar. */
1704 if (code
->expr1
->ts
.type
== BT_CLASS
1705 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1707 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1708 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1709 /* Adding the array ref to the class expression results in correct
1710 indexing to the dynamic type. */
1711 gfc_add_full_array_ref (lhs
, tmparr
);
1712 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1716 /* Scalar initialization needs the _data component. */
1717 gfc_add_data_component (lhs
);
1718 sz
= gfc_copy_expr (code
->expr1
);
1719 gfc_add_vptr_component (sz
);
1720 gfc_add_size_component (sz
);
1722 gfc_init_se (&dst
, NULL
);
1723 gfc_init_se (&src
, NULL
);
1724 gfc_init_se (&memsz
, NULL
);
1725 gfc_conv_expr (&dst
, lhs
);
1726 gfc_conv_expr (&src
, rhs
);
1727 gfc_conv_expr (&memsz
, sz
);
1728 gfc_add_block_to_block (&block
, &src
.pre
);
1729 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1731 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1733 if (UNLIMITED_POLY(code
->expr1
))
1735 /* Check if _def_init is non-NULL. */
1736 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1737 logical_type_node
, src
.expr
,
1738 fold_convert (TREE_TYPE (src
.expr
),
1739 null_pointer_node
));
1740 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1741 tmp
, build_empty_stmt (input_location
));
1745 if (code
->expr1
->symtree
->n
.sym
->attr
.dummy
1746 && (code
->expr1
->symtree
->n
.sym
->attr
.optional
1747 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
))
1749 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1750 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1752 build_empty_stmt (input_location
));
1755 gfc_add_expr_to_block (&block
, tmp
);
1757 return gfc_finish_block (&block
);
1761 /* Class valued elemental function calls or class array elements arriving
1762 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1763 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1766 trans_scalar_class_assign (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
)
1775 stmtblock_t inner_block
;
1777 bool not_call_expr
= TREE_CODE (rse
->expr
) != CALL_EXPR
;
1778 bool not_lhs_array_type
;
1780 /* Temporaries arising from depencies in assignment get cast as a
1781 character type of the dynamic size of the rhs. Use the vptr copy
1783 tmp
= TREE_TYPE (lse
->expr
);
1784 not_lhs_array_type
= !(tmp
&& TREE_CODE (tmp
) == ARRAY_TYPE
1785 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp
)) != NULL_TREE
);
1787 /* Use ordinary assignment if the rhs is not a call expression or
1788 the lhs is not a class entity or an array(ie. character) type. */
1789 if ((not_call_expr
&& gfc_get_class_from_expr (lse
->expr
) == NULL_TREE
)
1790 && not_lhs_array_type
)
1793 /* Ordinary assignment can be used if both sides are class expressions
1794 since the dynamic type is preserved by copying the vptr. This
1795 should only occur, where temporaries are involved. */
1796 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
1797 && GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
1800 /* Fix the class expression and the class data of the rhs. */
1801 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
1804 tmp
= gfc_get_class_from_expr (rse
->expr
);
1805 if (tmp
== NULL_TREE
)
1807 rse_expr
= gfc_evaluate_now (tmp
, block
);
1810 rse_expr
= gfc_evaluate_now (rse
->expr
, block
);
1812 class_data
= gfc_class_data_get (rse_expr
);
1814 /* Check that the rhs data is not null. */
1815 is_descriptor
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data
));
1817 class_data
= gfc_conv_descriptor_data_get (class_data
);
1818 class_data
= gfc_evaluate_now (class_data
, block
);
1820 zero
= build_int_cst (TREE_TYPE (class_data
), 0);
1821 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1825 /* Copy the rhs to the lhs. */
1826 fcn
= gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr
));
1827 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1828 tmp
= gfc_evaluate_now (gfc_build_addr_expr (NULL
, rse
->expr
), block
);
1829 tmp
= is_descriptor
? tmp
: class_data
;
1830 tmp
= build_call_expr_loc (input_location
, fcn
, 2, tmp
,
1831 gfc_build_addr_expr (NULL
, lse
->expr
));
1832 gfc_add_expr_to_block (block
, tmp
);
1834 /* Only elemental function results need to be finalised and freed. */
1838 /* Finalize the class data if needed. */
1839 gfc_init_block (&inner_block
);
1840 fcn
= gfc_vptr_final_get (gfc_class_vptr_get (rse_expr
));
1841 zero
= build_int_cst (TREE_TYPE (fcn
), 0);
1842 final_cond
= fold_build2_loc (input_location
, NE_EXPR
,
1843 logical_type_node
, fcn
, zero
);
1844 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
1845 tmp
= build_call_expr_loc (input_location
, fcn
, 1, class_data
);
1846 tmp
= build3_v (COND_EXPR
, final_cond
,
1847 tmp
, build_empty_stmt (input_location
));
1848 gfc_add_expr_to_block (&inner_block
, tmp
);
1850 /* Free the class data. */
1851 tmp
= gfc_call_free (class_data
);
1852 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1853 build_empty_stmt (input_location
));
1854 gfc_add_expr_to_block (&inner_block
, tmp
);
1856 /* Finish the inner block and subject it to the condition on the
1857 class data being non-zero. */
1858 tmp
= gfc_finish_block (&inner_block
);
1859 tmp
= build3_v (COND_EXPR
, cond
, tmp
,
1860 build_empty_stmt (input_location
));
1861 gfc_add_expr_to_block (block
, tmp
);
1866 /* End of prototype trans-class.c */
1870 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1872 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1873 gfc_warning (OPT_Wrealloc_lhs
,
1874 "Code for reallocating the allocatable array at %L will "
1876 else if (warn_realloc_lhs_all
)
1877 gfc_warning (OPT_Wrealloc_lhs_all
,
1878 "Code for reallocating the allocatable variable at %L "
1879 "will be added", where
);
1883 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1886 /* Copy the scalarization loop variables. */
1889 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1892 dest
->loop
= src
->loop
;
1896 /* Initialize a simple expression holder.
1898 Care must be taken when multiple se are created with the same parent.
1899 The child se must be kept in sync. The easiest way is to delay creation
1900 of a child se until after the previous se has been translated. */
1903 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1905 memset (se
, 0, sizeof (gfc_se
));
1906 gfc_init_block (&se
->pre
);
1907 gfc_init_block (&se
->post
);
1909 se
->parent
= parent
;
1912 gfc_copy_se_loopvars (se
, parent
);
1916 /* Advances to the next SS in the chain. Use this rather than setting
1917 se->ss = se->ss->next because all the parents needs to be kept in sync.
1921 gfc_advance_se_ss_chain (gfc_se
* se
)
1926 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1929 /* Walk down the parent chain. */
1932 /* Simple consistency check. */
1933 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1934 || p
->parent
->ss
->nested_ss
== p
->ss
);
1936 /* If we were in a nested loop, the next scalarized expression can be
1937 on the parent ss' next pointer. Thus we should not take the next
1938 pointer blindly, but rather go up one nest level as long as next
1939 is the end of chain. */
1941 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1951 /* Ensures the result of the expression as either a temporary variable
1952 or a constant so that it can be used repeatedly. */
1955 gfc_make_safe_expr (gfc_se
* se
)
1959 if (CONSTANT_CLASS_P (se
->expr
))
1962 /* We need a temporary for this result. */
1963 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1964 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1969 /* Return an expression which determines if a dummy parameter is present.
1970 Also used for arguments to procedures with multiple entry points. */
1973 gfc_conv_expr_present (gfc_symbol
* sym
, bool use_saved_desc
)
1975 tree decl
, orig_decl
, cond
;
1977 gcc_assert (sym
->attr
.dummy
);
1978 orig_decl
= decl
= gfc_get_symbol_decl (sym
);
1980 /* Intrinsic scalars with VALUE attribute which are passed by value
1981 use a hidden argument to denote the present status. */
1982 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1983 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1984 && !sym
->attr
.dimension
)
1986 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1989 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1991 strcpy (&name
[1], sym
->name
);
1992 tree_name
= get_identifier (name
);
1994 /* Walk function argument list to find hidden arg. */
1995 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1996 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1997 if (DECL_NAME (cond
) == tree_name
1998 && DECL_ARTIFICIAL (cond
))
2005 /* Assumed-shape arrays use a local variable for the array data;
2006 the actual PARAM_DECL is in a saved decl. As the local variable
2007 is NULL, it can be checked instead, unless use_saved_desc is
2010 if (use_saved_desc
&& TREE_CODE (decl
) != PARM_DECL
)
2012 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
2013 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
2014 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
2017 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
2018 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
2020 /* Fortran 2008 allows to pass null pointers and non-associated pointers
2021 as actual argument to denote absent dummies. For array descriptors,
2022 we thus also need to check the array descriptor. For BT_CLASS, it
2023 can also occur for scalars and F2003 due to type->class wrapping and
2024 class->class wrapping. Note further that BT_CLASS always uses an
2025 array descriptor for arrays, also for explicit-shape/assumed-size.
2026 For assumed-rank arrays, no local variable is generated, hence,
2027 the following also applies with !use_saved_desc. */
2029 if ((use_saved_desc
|| TREE_CODE (orig_decl
) == PARM_DECL
)
2030 && !sym
->attr
.allocatable
2031 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
2032 || (sym
->ts
.type
== BT_CLASS
2033 && !CLASS_DATA (sym
)->attr
.allocatable
2034 && !CLASS_DATA (sym
)->attr
.class_pointer
))
2035 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
2036 || sym
->ts
.type
== BT_CLASS
))
2040 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
2041 || sym
->as
->type
== AS_ASSUMED_RANK
2042 || sym
->attr
.codimension
))
2043 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
2045 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
2046 if (sym
->ts
.type
== BT_CLASS
)
2047 tmp
= gfc_class_data_get (tmp
);
2048 tmp
= gfc_conv_array_data (tmp
);
2050 else if (sym
->ts
.type
== BT_CLASS
)
2051 tmp
= gfc_class_data_get (decl
);
2055 if (tmp
!= NULL_TREE
)
2057 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
2058 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
2059 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2060 logical_type_node
, cond
, tmp
);
2068 /* Converts a missing, dummy argument into a null or zero. */
2071 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
2076 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
2080 /* Create a temporary and convert it to the correct type. */
2081 tmp
= gfc_get_int_type (kind
);
2082 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
2085 /* Test for a NULL value. */
2086 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
2087 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
2088 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2089 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2093 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
2095 build_zero_cst (TREE_TYPE (se
->expr
)));
2096 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2100 if (ts
.type
== BT_CHARACTER
)
2102 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2103 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
2104 present
, se
->string_length
, tmp
);
2105 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2106 se
->string_length
= tmp
;
2112 /* Get the character length of an expression, looking through gfc_refs
2116 gfc_get_expr_charlen (gfc_expr
*e
)
2122 gcc_assert (e
->expr_type
== EXPR_VARIABLE
2123 && e
->ts
.type
== BT_CHARACTER
);
2125 length
= NULL
; /* To silence compiler warning. */
2127 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
2130 gfc_init_se (&tmpse
, NULL
);
2131 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
2132 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
2136 /* First candidate: if the variable is of type CHARACTER, the
2137 expression's length could be the length of the character
2139 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2140 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2142 /* Look through the reference chain for component references. */
2143 for (r
= e
->ref
; r
; r
= r
->next
)
2148 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
2149 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
2157 gfc_init_se (&se
, NULL
);
2158 gfc_conv_expr_type (&se
, r
->u
.ss
.start
, gfc_charlen_type_node
);
2160 gfc_conv_expr_type (&se
, r
->u
.ss
.end
, gfc_charlen_type_node
);
2161 length
= fold_build2_loc (input_location
, MINUS_EXPR
,
2162 gfc_charlen_type_node
,
2164 length
= fold_build2_loc (input_location
, PLUS_EXPR
,
2165 gfc_charlen_type_node
, length
,
2166 gfc_index_one_node
);
2175 gcc_assert (length
!= NULL
);
2180 /* Return for an expression the backend decl of the coarray. */
2183 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
2189 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
2191 /* Not-implemented diagnostic. */
2192 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
2193 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
2194 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2195 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2196 "%L is not supported", &expr
->where
);
2198 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2199 if (ref
->type
== REF_COMPONENT
)
2201 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
2202 && UNLIMITED_POLY (ref
->u
.c
.component
)
2203 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
2204 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2205 "component at %L is not supported", &expr
->where
);
2208 /* Make sure the backend_decl is present before accessing it. */
2209 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
2210 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
2211 : expr
->symtree
->n
.sym
->backend_decl
;
2213 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
2215 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
2217 caf_decl
= gfc_class_data_get (caf_decl
);
2218 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2221 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2223 if (ref
->type
== REF_COMPONENT
2224 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
2226 caf_decl
= gfc_class_data_get (caf_decl
);
2227 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
2231 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
2235 if (expr
->symtree
->n
.sym
->attr
.codimension
)
2238 /* The following code assumes that the coarray is a component reachable via
2239 only scalar components/variables; the Fortran standard guarantees this. */
2241 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2242 if (ref
->type
== REF_COMPONENT
)
2244 gfc_component
*comp
= ref
->u
.c
.component
;
2246 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
2247 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
2248 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2249 TREE_TYPE (comp
->backend_decl
), caf_decl
,
2250 comp
->backend_decl
, NULL_TREE
);
2251 if (comp
->ts
.type
== BT_CLASS
)
2253 caf_decl
= gfc_class_data_get (caf_decl
);
2254 if (CLASS_DATA (comp
)->attr
.codimension
)
2260 if (comp
->attr
.codimension
)
2266 gcc_assert (found
&& caf_decl
);
2271 /* Obtain the Coarray token - and optionally also the offset. */
2274 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
2275 tree se_expr
, gfc_expr
*expr
)
2279 /* Coarray token. */
2280 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2282 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
2283 == GFC_ARRAY_ALLOCATABLE
2284 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
2285 *token
= gfc_conv_descriptor_token (caf_decl
);
2287 else if (DECL_LANG_SPECIFIC (caf_decl
)
2288 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
2289 *token
= GFC_DECL_TOKEN (caf_decl
);
2292 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
2293 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
2294 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
2300 /* Offset between the coarray base address and the address wanted. */
2301 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
2302 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2303 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2304 *offset
= build_int_cst (gfc_array_index_type
, 0);
2305 else if (DECL_LANG_SPECIFIC (caf_decl
)
2306 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2307 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2308 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2309 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2311 *offset
= build_int_cst (gfc_array_index_type
, 0);
2313 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2314 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2316 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2317 tmp
= gfc_conv_descriptor_data_get (tmp
);
2319 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2320 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2323 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2327 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2328 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2330 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2331 && expr
->symtree
->n
.sym
->attr
.codimension
2332 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2334 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2335 gfc_ref
*ref
= base_expr
->ref
;
2338 // Iterate through the refs until the last one.
2342 if (ref
->type
== REF_ARRAY
2343 && ref
->u
.ar
.type
!= AR_FULL
)
2345 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2347 for (i
= 0; i
< ranksum
; ++i
)
2349 ref
->u
.ar
.start
[i
] = NULL
;
2350 ref
->u
.ar
.end
[i
] = NULL
;
2352 ref
->u
.ar
.type
= AR_FULL
;
2354 gfc_init_se (&base_se
, NULL
);
2355 if (gfc_caf_attr (base_expr
).dimension
)
2357 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2358 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2362 gfc_conv_expr (&base_se
, base_expr
);
2366 gfc_free_expr (base_expr
);
2367 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2368 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2370 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2371 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2378 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2379 fold_convert (gfc_array_index_type
, *offset
),
2380 fold_convert (gfc_array_index_type
, tmp
));
2384 /* Convert the coindex of a coarray into an image index; the result is
2385 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2386 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2389 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2392 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2396 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2397 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2399 gcc_assert (ref
!= NULL
);
2401 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2403 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2407 img_idx
= build_zero_cst (gfc_array_index_type
);
2408 extent
= build_one_cst (gfc_array_index_type
);
2409 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2410 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2412 gfc_init_se (&se
, NULL
);
2413 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2414 gfc_add_block_to_block (block
, &se
.pre
);
2415 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2416 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2417 TREE_TYPE (lbound
), se
.expr
, lbound
);
2418 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2420 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
,
2421 TREE_TYPE (tmp
), img_idx
, tmp
);
2422 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2424 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2425 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2426 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2427 TREE_TYPE (tmp
), extent
, tmp
);
2431 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2433 gfc_init_se (&se
, NULL
);
2434 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], gfc_array_index_type
);
2435 gfc_add_block_to_block (block
, &se
.pre
);
2436 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2437 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2438 TREE_TYPE (lbound
), se
.expr
, lbound
);
2439 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
2441 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2443 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2445 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2446 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2447 TREE_TYPE (ubound
), ubound
, lbound
);
2448 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (tmp
),
2449 tmp
, build_one_cst (TREE_TYPE (tmp
)));
2450 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2451 TREE_TYPE (tmp
), extent
, tmp
);
2454 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (img_idx
),
2455 img_idx
, build_one_cst (TREE_TYPE (img_idx
)));
2456 return fold_convert (integer_type_node
, img_idx
);
2460 /* For each character array constructor subexpression without a ts.u.cl->length,
2461 replace it by its first element (if there aren't any elements, the length
2462 should already be set to zero). */
2465 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2467 gfc_actual_arglist
* arg
;
2473 switch (e
->expr_type
)
2477 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2478 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2482 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2486 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2487 flatten_array_ctors_without_strlen (arg
->expr
);
2492 /* We've found what we're looking for. */
2493 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2498 gcc_assert (e
->value
.constructor
);
2500 c
= gfc_constructor_first (e
->value
.constructor
);
2504 flatten_array_ctors_without_strlen (new_expr
);
2505 gfc_replace_expr (e
, new_expr
);
2509 /* Otherwise, fall through to handle constructor elements. */
2511 case EXPR_STRUCTURE
:
2512 for (c
= gfc_constructor_first (e
->value
.constructor
);
2513 c
; c
= gfc_constructor_next (c
))
2514 flatten_array_ctors_without_strlen (c
->expr
);
2524 /* Generate code to initialize a string length variable. Returns the
2525 value. For array constructors, cl->length might be NULL and in this case,
2526 the first element of the constructor is needed. expr is the original
2527 expression so we can access it but can be NULL if this is not needed. */
2530 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2534 gfc_init_se (&se
, NULL
);
2536 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2539 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2540 "flatten" array constructors by taking their first element; all elements
2541 should be the same length or a cl->length should be present. */
2544 gfc_expr
* expr_flat
;
2547 expr_flat
= gfc_copy_expr (expr
);
2548 flatten_array_ctors_without_strlen (expr_flat
);
2549 gfc_resolve_expr (expr_flat
);
2551 gfc_conv_expr (&se
, expr_flat
);
2552 gfc_add_block_to_block (pblock
, &se
.pre
);
2553 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2555 gfc_free_expr (expr_flat
);
2559 /* Convert cl->length. */
2561 gcc_assert (cl
->length
);
2563 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2564 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2565 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2566 gfc_add_block_to_block (pblock
, &se
.pre
);
2568 if (cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2569 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2571 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2576 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2577 const char *name
, locus
*where
)
2587 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2588 type
= build_pointer_type (type
);
2590 gfc_init_se (&start
, se
);
2591 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2592 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2594 if (integer_onep (start
.expr
))
2595 gfc_conv_string_parameter (se
);
2600 /* Avoid multiple evaluation of substring start. */
2601 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2602 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2604 /* Change the start of the string. */
2605 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
2606 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
2607 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2610 tmp
= build_fold_indirect_ref_loc (input_location
,
2612 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2613 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
2615 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2616 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2620 /* Length = end + 1 - start. */
2621 gfc_init_se (&end
, se
);
2622 if (ref
->u
.ss
.end
== NULL
)
2623 end
.expr
= se
->string_length
;
2626 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2627 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2631 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2632 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2634 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2635 && (ref
->u
.ss
.start
->symtree
2636 && !ref
->u
.ss
.start
->symtree
->n
.sym
->attr
.implied_index
))
2638 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2639 logical_type_node
, start
.expr
,
2642 /* Check lower bound. */
2643 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2645 build_one_cst (TREE_TYPE (start
.expr
)));
2646 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2647 logical_type_node
, nonempty
, fault
);
2649 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2650 "is less than one", name
);
2652 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2653 "is less than one");
2654 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2655 fold_convert (long_integer_type_node
,
2659 /* Check upper bound. */
2660 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2661 end
.expr
, se
->string_length
);
2662 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2663 logical_type_node
, nonempty
, fault
);
2665 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2666 "exceeds string length (%%ld)", name
);
2668 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2669 "exceeds string length (%%ld)");
2670 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2671 fold_convert (long_integer_type_node
, end
.expr
),
2672 fold_convert (long_integer_type_node
,
2673 se
->string_length
));
2677 /* Try to calculate the length from the start and end expressions. */
2679 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2681 HOST_WIDE_INT i_len
;
2683 i_len
= gfc_mpz_get_hwi (length
) + 1;
2687 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2688 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2692 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2693 fold_convert (gfc_charlen_type_node
, end
.expr
),
2694 fold_convert (gfc_charlen_type_node
, start
.expr
));
2695 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2696 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2697 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2698 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2701 se
->string_length
= tmp
;
2705 /* Convert a derived type component reference. */
2708 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2716 c
= ref
->u
.c
.component
;
2718 if (c
->backend_decl
== NULL_TREE
2719 && ref
->u
.c
.sym
!= NULL
)
2720 gfc_get_derived_type (ref
->u
.c
.sym
);
2722 field
= c
->backend_decl
;
2723 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2725 context
= DECL_FIELD_CONTEXT (field
);
2727 /* Components can correspond to fields of different containing
2728 types, as components are created without context, whereas
2729 a concrete use of a component has the type of decl as context.
2730 So, if the type doesn't match, we search the corresponding
2731 FIELD_DECL in the parent type. To not waste too much time
2732 we cache this result in norestrict_decl.
2733 On the other hand, if the context is a UNION or a MAP (a
2734 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2736 if (context
!= TREE_TYPE (decl
)
2737 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2738 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2740 tree f2
= c
->norestrict_decl
;
2741 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2742 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2743 if (TREE_CODE (f2
) == FIELD_DECL
2744 && DECL_NAME (f2
) == DECL_NAME (field
))
2747 c
->norestrict_decl
= f2
;
2751 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2752 && strcmp ("_data", c
->name
) == 0)
2754 /* Found a ref to the _data component. Store the associated ref to
2755 the vptr in se->class_vptr. */
2756 se
->class_vptr
= gfc_class_vptr_get (decl
);
2759 se
->class_vptr
= NULL_TREE
;
2761 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2762 decl
, field
, NULL_TREE
);
2766 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2767 strlen () conditional below. */
2768 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2770 && !c
->attr
.pdt_string
)
2772 tmp
= c
->ts
.u
.cl
->backend_decl
;
2773 /* Components must always be constant length. */
2774 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2775 se
->string_length
= tmp
;
2778 if (gfc_deferred_strlen (c
, &field
))
2780 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2782 decl
, field
, NULL_TREE
);
2783 se
->string_length
= tmp
;
2786 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2787 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2788 && c
->ts
.type
!= BT_CHARACTER
)
2789 || c
->attr
.proc_pointer
)
2790 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2795 /* This function deals with component references to components of the
2796 parent type for derived type extensions. */
2798 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2806 c
= ref
->u
.c
.component
;
2808 /* Return if the component is in the parent type. */
2809 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2810 if (strcmp (c
->name
, cmp
->name
) == 0)
2813 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2814 parent
.type
= REF_COMPONENT
;
2816 parent
.u
.c
.sym
= dt
;
2817 parent
.u
.c
.component
= dt
->components
;
2819 if (dt
->backend_decl
== NULL
)
2820 gfc_get_derived_type (dt
);
2822 /* Build the reference and call self. */
2823 gfc_conv_component_ref (se
, &parent
);
2824 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2825 parent
.u
.c
.component
= c
;
2826 conv_parent_component_references (se
, &parent
);
2831 conv_inquiry (gfc_se
* se
, gfc_ref
* ref
, gfc_expr
*expr
, gfc_typespec
*ts
)
2833 tree res
= se
->expr
;
2838 res
= fold_build1_loc (input_location
, REALPART_EXPR
,
2839 TREE_TYPE (TREE_TYPE (res
)), res
);
2843 res
= fold_build1_loc (input_location
, IMAGPART_EXPR
,
2844 TREE_TYPE (TREE_TYPE (res
)), res
);
2848 res
= build_int_cst (gfc_typenode_for_spec (&expr
->ts
),
2853 res
= fold_convert (gfc_typenode_for_spec (&expr
->ts
),
2863 /* Dereference VAR where needed if it is a pointer, reference, etc.
2864 according to Fortran semantics. */
2867 gfc_maybe_dereference_var (gfc_symbol
*sym
, tree var
, bool descriptor_only_p
,
2870 if (is_CFI_desc (sym
, NULL
))
2871 return build_fold_indirect_ref_loc (input_location
, var
);
2873 /* Characters are entirely different from other types, they are treated
2875 if (sym
->ts
.type
== BT_CHARACTER
)
2877 /* Dereference character pointer dummy arguments
2879 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2880 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2882 || sym
->attr
.function
2883 || sym
->attr
.result
))
2884 var
= build_fold_indirect_ref_loc (input_location
, var
);
2886 else if (!sym
->attr
.value
)
2888 /* Dereference temporaries for class array dummy arguments. */
2889 if (sym
->attr
.dummy
&& is_classarray
2890 && GFC_ARRAY_TYPE_P (TREE_TYPE (var
)))
2892 if (!descriptor_only_p
)
2893 var
= GFC_DECL_SAVED_DESCRIPTOR (var
);
2895 var
= build_fold_indirect_ref_loc (input_location
, var
);
2898 /* Dereference non-character scalar dummy arguments. */
2899 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2900 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2901 && (sym
->ts
.type
!= BT_CLASS
2902 || (!CLASS_DATA (sym
)->attr
.dimension
2903 && !(CLASS_DATA (sym
)->attr
.codimension
2904 && CLASS_DATA (sym
)->attr
.allocatable
))))
2905 var
= build_fold_indirect_ref_loc (input_location
, var
);
2907 /* Dereference scalar hidden result. */
2908 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2909 && (sym
->attr
.function
|| sym
->attr
.result
)
2910 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2911 && !sym
->attr
.always_explicit
)
2912 var
= build_fold_indirect_ref_loc (input_location
, var
);
2914 /* Dereference non-character, non-class pointer variables.
2915 These must be dummies, results, or scalars. */
2917 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2918 || gfc_is_associate_pointer (sym
)
2919 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2921 || sym
->attr
.function
2923 || (!sym
->attr
.dimension
2924 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2925 var
= build_fold_indirect_ref_loc (input_location
, var
);
2926 /* Now treat the class array pointer variables accordingly. */
2927 else if (sym
->ts
.type
== BT_CLASS
2929 && (CLASS_DATA (sym
)->attr
.dimension
2930 || CLASS_DATA (sym
)->attr
.codimension
)
2931 && ((CLASS_DATA (sym
)->as
2932 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2933 || CLASS_DATA (sym
)->attr
.allocatable
2934 || CLASS_DATA (sym
)->attr
.class_pointer
))
2935 var
= build_fold_indirect_ref_loc (input_location
, var
);
2936 /* And the case where a non-dummy, non-result, non-function,
2937 non-allotable and non-pointer classarray is present. This case was
2938 previously covered by the first if, but with introducing the
2939 condition !is_classarray there, that case has to be covered
2941 else if (sym
->ts
.type
== BT_CLASS
2943 && !sym
->attr
.function
2944 && !sym
->attr
.result
2945 && (CLASS_DATA (sym
)->attr
.dimension
2946 || CLASS_DATA (sym
)->attr
.codimension
)
2948 || !CLASS_DATA (sym
)->attr
.allocatable
)
2949 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2950 var
= build_fold_indirect_ref_loc (input_location
, var
);
2956 /* Return the contents of a variable. Also handles reference/pointer
2957 variables (all Fortran pointer references are implicit). */
2960 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2965 tree parent_decl
= NULL_TREE
;
2968 bool alternate_entry
;
2971 bool first_time
= true;
2973 sym
= expr
->symtree
->n
.sym
;
2974 is_classarray
= IS_CLASS_ARRAY (sym
);
2978 gfc_ss_info
*ss_info
= ss
->info
;
2980 /* Check that something hasn't gone horribly wrong. */
2981 gcc_assert (ss
!= gfc_ss_terminator
);
2982 gcc_assert (ss_info
->expr
== expr
);
2984 /* A scalarized term. We already know the descriptor. */
2985 se
->expr
= ss_info
->data
.array
.descriptor
;
2986 se
->string_length
= ss_info
->string_length
;
2987 ref
= ss_info
->data
.array
.ref
;
2989 gcc_assert (ref
->type
== REF_ARRAY
2990 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2992 gfc_conv_tmp_array_ref (se
);
2996 tree se_expr
= NULL_TREE
;
2998 se
->expr
= gfc_get_symbol_decl (sym
);
3000 /* Deal with references to a parent results or entries by storing
3001 the current_function_decl and moving to the parent_decl. */
3002 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
3003 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
3004 && sym
->result
== sym
;
3005 entry_master
= sym
->attr
.result
3006 && sym
->ns
->proc_name
->attr
.entry_master
3007 && !gfc_return_by_reference (sym
->ns
->proc_name
);
3008 if (current_function_decl
)
3009 parent_decl
= DECL_CONTEXT (current_function_decl
);
3011 if ((se
->expr
== parent_decl
&& return_value
)
3012 || (sym
->ns
&& sym
->ns
->proc_name
3014 && sym
->ns
->proc_name
->backend_decl
== parent_decl
3015 && (alternate_entry
|| entry_master
)))
3020 /* Special case for assigning the return value of a function.
3021 Self recursive functions must have an explicit return value. */
3022 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
3023 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3025 /* Similarly for alternate entry points. */
3026 else if (alternate_entry
3027 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
3030 gfc_entry_list
*el
= NULL
;
3032 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3035 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3040 else if (entry_master
3041 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
3043 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
3048 /* Procedure actual arguments. Look out for temporary variables
3049 with the same attributes as function values. */
3050 else if (!sym
->attr
.temporary
3051 && sym
->attr
.flavor
== FL_PROCEDURE
3052 && se
->expr
!= current_function_decl
)
3054 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
3056 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
3057 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3062 /* Dereference the expression, where needed. */
3063 se
->expr
= gfc_maybe_dereference_var (sym
, se
->expr
, se
->descriptor_only
,
3069 /* For character variables, also get the length. */
3070 if (sym
->ts
.type
== BT_CHARACTER
)
3072 /* If the character length of an entry isn't set, get the length from
3073 the master function instead. */
3074 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
3075 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
3077 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3078 gcc_assert (se
->string_length
);
3081 gfc_typespec
*ts
= &sym
->ts
;
3087 /* Return the descriptor if that's what we want and this is an array
3088 section reference. */
3089 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
3091 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3092 /* Return the descriptor for array pointers and allocations. */
3093 if (se
->want_pointer
3094 && ref
->next
== NULL
&& (se
->descriptor_only
))
3097 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
3098 /* Return a pointer to an element. */
3102 ts
= &ref
->u
.c
.component
->ts
;
3103 if (first_time
&& is_classarray
&& sym
->attr
.dummy
3104 && se
->descriptor_only
3105 && !CLASS_DATA (sym
)->attr
.allocatable
3106 && !CLASS_DATA (sym
)->attr
.class_pointer
3107 && CLASS_DATA (sym
)->as
3108 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
3109 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
3110 /* Skip the first ref of a _data component, because for class
3111 arrays that one is already done by introducing a temporary
3112 array descriptor. */
3115 if (ref
->u
.c
.sym
->attr
.extension
)
3116 conv_parent_component_references (se
, ref
);
3118 gfc_conv_component_ref (se
, ref
);
3119 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
3120 && se
->want_pointer
&& se
->descriptor_only
)
3126 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
3127 expr
->symtree
->name
, &expr
->where
);
3131 conv_inquiry (se
, ref
, expr
, ts
);
3141 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3143 if (se
->want_pointer
)
3145 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
3146 gfc_conv_string_parameter (se
);
3148 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
3153 /* Unary ops are easy... Or they would be if ! was a valid op. */
3156 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
3161 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3162 /* Initialize the operand. */
3163 gfc_init_se (&operand
, se
);
3164 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
3165 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
3167 type
= gfc_typenode_for_spec (&expr
->ts
);
3169 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3170 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3171 All other unary operators have an equivalent GIMPLE unary operator. */
3172 if (code
== TRUTH_NOT_EXPR
)
3173 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
3174 build_int_cst (type
, 0));
3176 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
3180 /* Expand power operator to optimal multiplications when a value is raised
3181 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3182 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3183 Programming", 3rd Edition, 1998. */
3185 /* This code is mostly duplicated from expand_powi in the backend.
3186 We establish the "optimal power tree" lookup table with the defined size.
3187 The items in the table are the exponents used to calculate the index
3188 exponents. Any integer n less than the value can get an "addition chain",
3189 with the first node being one. */
3190 #define POWI_TABLE_SIZE 256
3192 /* The table is from builtins.c. */
3193 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
3195 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3196 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3197 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3198 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3199 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3200 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3201 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3202 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3203 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3204 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3205 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3206 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3207 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3208 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3209 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3210 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3211 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3212 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3213 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3214 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3215 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3216 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3217 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3218 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3219 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3220 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3221 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3222 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3223 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3224 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3225 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3226 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3229 /* If n is larger than lookup table's max index, we use the "window
3231 #define POWI_WINDOW_SIZE 3
3233 /* Recursive function to expand the power operator. The temporary
3234 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3236 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
3243 if (n
< POWI_TABLE_SIZE
)
3248 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
3249 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
3253 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
3254 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
3255 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
3259 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
3263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
3264 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3266 if (n
< POWI_TABLE_SIZE
)
3273 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3274 return 1. Else return 0 and a call to runtime library functions
3275 will have to be built. */
3277 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
3282 tree vartmp
[POWI_TABLE_SIZE
];
3284 unsigned HOST_WIDE_INT n
;
3286 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
3288 /* If exponent is too large, we won't expand it anyway, so don't bother
3289 with large integer values. */
3290 if (!wi::fits_shwi_p (wrhs
))
3293 m
= wrhs
.to_shwi ();
3294 /* Use the wide_int's routine to reliably get the absolute value on all
3295 platforms. Then convert it to a HOST_WIDE_INT like above. */
3296 n
= wi::abs (wrhs
).to_shwi ();
3298 type
= TREE_TYPE (lhs
);
3299 sgn
= tree_int_cst_sgn (rhs
);
3301 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
3302 || optimize_size
) && (m
> 2 || m
< -1))
3308 se
->expr
= gfc_build_const (type
, integer_one_node
);
3312 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3313 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
3315 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3316 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
3317 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3318 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
3321 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3324 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
3325 logical_type_node
, tmp
, cond
);
3326 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3327 tmp
, build_int_cst (type
, 1),
3328 build_int_cst (type
, 0));
3332 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3333 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
3334 build_int_cst (type
, -1),
3335 build_int_cst (type
, 0));
3336 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
3337 cond
, build_int_cst (type
, 1), tmp
);
3341 memset (vartmp
, 0, sizeof (vartmp
));
3345 tmp
= gfc_build_const (type
, integer_one_node
);
3346 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
3350 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
3356 /* Power op (**). Constant integer exponent has special handling. */
3359 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3361 tree gfc_int4_type_node
;
3364 int res_ikind_1
, res_ikind_2
;
3369 gfc_init_se (&lse
, se
);
3370 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3371 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3372 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3374 gfc_init_se (&rse
, se
);
3375 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3376 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3378 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3379 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3380 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3383 if (INTEGER_CST_P (lse
.expr
)
3384 && TREE_CODE (TREE_TYPE (rse
.expr
)) == INTEGER_TYPE
)
3386 wi::tree_to_wide_ref wlhs
= wi::to_wide (lse
.expr
);
3388 int kind
, ikind
, bit_size
;
3390 v
= wlhs
.to_shwi ();
3393 kind
= expr
->value
.op
.op1
->ts
.kind
;
3394 ikind
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3395 bit_size
= gfc_integer_kinds
[ikind
].bit_size
;
3399 /* 1**something is always 1. */
3400 se
->expr
= build_int_cst (TREE_TYPE (lse
.expr
), 1);
3405 /* (-1)**n is 1 - ((n & 1) << 1) */
3409 type
= TREE_TYPE (lse
.expr
);
3410 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3411 rse
.expr
, build_int_cst (type
, 1));
3412 tmp
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3413 tmp
, build_int_cst (type
, 1));
3414 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3415 build_int_cst (type
, 1), tmp
);
3419 else if (w
> 0 && ((w
& (w
-1)) == 0) && ((w
>> (bit_size
-1)) == 0))
3421 /* Here v is +/- 2**e. The further simplification uses
3422 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3423 1<<(4*n), etc., but we have to make sure to return zero
3424 if the number of bits is too large. */
3434 type
= TREE_TYPE (lse
.expr
);
3439 shift
= fold_build2_loc (input_location
, PLUS_EXPR
,
3440 TREE_TYPE (rse
.expr
),
3441 rse
.expr
, rse
.expr
);
3444 /* use popcount for fast log2(w) */
3445 int e
= wi::popcount (w
-1);
3446 shift
= fold_build2_loc (input_location
, MULT_EXPR
,
3447 TREE_TYPE (rse
.expr
),
3448 build_int_cst (TREE_TYPE (rse
.expr
), e
),
3452 lshift
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3453 build_int_cst (type
, 1), shift
);
3454 ge
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3455 rse
.expr
, build_int_cst (type
, 0));
3456 cond
= fold_build3_loc (input_location
, COND_EXPR
, type
, ge
, lshift
,
3457 build_int_cst (type
, 0));
3458 num_bits
= build_int_cst (TREE_TYPE (rse
.expr
), TYPE_PRECISION (type
));
3459 cond2
= fold_build2_loc (input_location
, GE_EXPR
, logical_type_node
,
3460 rse
.expr
, num_bits
);
3461 tmp1
= fold_build3_loc (input_location
, COND_EXPR
, type
, cond2
,
3462 build_int_cst (type
, 0), cond
);
3469 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3471 tmp2
= fold_build2_loc (input_location
, BIT_AND_EXPR
, type
,
3472 rse
.expr
, build_int_cst (type
, 1));
3473 tmp2
= fold_build2_loc (input_location
, LSHIFT_EXPR
, type
,
3474 tmp2
, build_int_cst (type
, 1));
3475 tmp2
= fold_build2_loc (input_location
, MINUS_EXPR
, type
,
3476 build_int_cst (type
, 1), tmp2
);
3477 se
->expr
= fold_build2_loc (input_location
, MULT_EXPR
, type
,
3484 gfc_int4_type_node
= gfc_get_int_type (4);
3486 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3487 library routine. But in the end, we have to convert the result back
3488 if this case applies -- with res_ikind_K, we keep track whether operand K
3489 falls into this case. */
3493 kind
= expr
->value
.op
.op1
->ts
.kind
;
3494 switch (expr
->value
.op
.op2
->ts
.type
)
3497 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3502 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3503 res_ikind_2
= ikind
;
3525 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3527 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3554 switch (expr
->value
.op
.op1
->ts
.type
)
3557 if (kind
== 3) /* Case 16 was not handled properly above. */
3559 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3563 /* Use builtins for real ** int4. */
3569 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3573 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3577 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3581 /* Use the __builtin_powil() only if real(kind=16) is
3582 actually the C long double type. */
3583 if (!gfc_real16_is_float128
)
3584 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3592 /* If we don't have a good builtin for this, go for the
3593 library function. */
3595 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3599 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3608 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3612 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3620 se
->expr
= build_call_expr_loc (input_location
,
3621 fndecl
, 2, lse
.expr
, rse
.expr
);
3623 /* Convert the result back if it is of wrong integer kind. */
3624 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3626 /* We want the maximum of both operand kinds as result. */
3627 if (res_ikind_1
< res_ikind_2
)
3628 res_ikind_1
= res_ikind_2
;
3629 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3634 /* Generate code to allocate a string temporary. */
3637 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3642 if (gfc_can_put_var_on_stack (len
))
3644 /* Create a temporary variable to hold the result. */
3645 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3646 TREE_TYPE (len
), len
,
3647 build_int_cst (TREE_TYPE (len
), 1));
3648 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3650 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3651 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3653 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3655 var
= gfc_create_var (tmp
, "str");
3656 var
= gfc_build_addr_expr (type
, var
);
3660 /* Allocate a temporary to hold the result. */
3661 var
= gfc_create_var (type
, "pstr");
3662 gcc_assert (POINTER_TYPE_P (type
));
3663 tmp
= TREE_TYPE (type
);
3664 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3665 tmp
= TREE_TYPE (tmp
);
3666 tmp
= TYPE_SIZE_UNIT (tmp
);
3667 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3668 fold_convert (size_type_node
, len
),
3669 fold_convert (size_type_node
, tmp
));
3670 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3671 gfc_add_modify (&se
->pre
, var
, tmp
);
3673 /* Free the temporary afterwards. */
3674 tmp
= gfc_call_free (var
);
3675 gfc_add_expr_to_block (&se
->post
, tmp
);
3682 /* Handle a string concatenation operation. A temporary will be allocated to
3686 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3689 tree len
, type
, var
, tmp
, fndecl
;
3691 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3692 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3693 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3695 gfc_init_se (&lse
, se
);
3696 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3697 gfc_conv_string_parameter (&lse
);
3698 gfc_init_se (&rse
, se
);
3699 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3700 gfc_conv_string_parameter (&rse
);
3702 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3703 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3705 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3706 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3707 if (len
== NULL_TREE
)
3709 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3710 gfc_charlen_type_node
,
3711 fold_convert (gfc_charlen_type_node
,
3713 fold_convert (gfc_charlen_type_node
,
3714 rse
.string_length
));
3717 type
= build_pointer_type (type
);
3719 var
= gfc_conv_string_tmp (se
, type
, len
);
3721 /* Do the actual concatenation. */
3722 if (expr
->ts
.kind
== 1)
3723 fndecl
= gfor_fndecl_concat_string
;
3724 else if (expr
->ts
.kind
== 4)
3725 fndecl
= gfor_fndecl_concat_string_char4
;
3729 tmp
= build_call_expr_loc (input_location
,
3730 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3731 rse
.string_length
, rse
.expr
);
3732 gfc_add_expr_to_block (&se
->pre
, tmp
);
3734 /* Add the cleanup for the operands. */
3735 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3736 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3739 se
->string_length
= len
;
3742 /* Translates an op expression. Common (binary) cases are handled by this
3743 function, others are passed on. Recursion is used in either case.
3744 We use the fact that (op1.ts == op2.ts) (except for the power
3746 Operators need no special handling for scalarized expressions as long as
3747 they call gfc_conv_simple_val to get their operands.
3748 Character strings get special handling. */
3751 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3753 enum tree_code code
;
3762 switch (expr
->value
.op
.op
)
3764 case INTRINSIC_PARENTHESES
:
3765 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3766 && flag_protect_parens
)
3768 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3769 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3774 case INTRINSIC_UPLUS
:
3775 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3778 case INTRINSIC_UMINUS
:
3779 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3783 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3786 case INTRINSIC_PLUS
:
3790 case INTRINSIC_MINUS
:
3794 case INTRINSIC_TIMES
:
3798 case INTRINSIC_DIVIDE
:
3799 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3800 an integer, we must round towards zero, so we use a
3802 if (expr
->ts
.type
== BT_INTEGER
)
3803 code
= TRUNC_DIV_EXPR
;
3808 case INTRINSIC_POWER
:
3809 gfc_conv_power_op (se
, expr
);
3812 case INTRINSIC_CONCAT
:
3813 gfc_conv_concat_op (se
, expr
);
3817 code
= flag_frontend_optimize
? TRUTH_ANDIF_EXPR
: TRUTH_AND_EXPR
;
3822 code
= flag_frontend_optimize
? TRUTH_ORIF_EXPR
: TRUTH_OR_EXPR
;
3826 /* EQV and NEQV only work on logicals, but since we represent them
3827 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3829 case INTRINSIC_EQ_OS
:
3837 case INTRINSIC_NE_OS
:
3838 case INTRINSIC_NEQV
:
3845 case INTRINSIC_GT_OS
:
3852 case INTRINSIC_GE_OS
:
3859 case INTRINSIC_LT_OS
:
3866 case INTRINSIC_LE_OS
:
3872 case INTRINSIC_USER
:
3873 case INTRINSIC_ASSIGN
:
3874 /* These should be converted into function calls by the frontend. */
3878 fatal_error (input_location
, "Unknown intrinsic op");
3882 /* The only exception to this is **, which is handled separately anyway. */
3883 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3885 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3889 gfc_init_se (&lse
, se
);
3890 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3891 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3894 gfc_init_se (&rse
, se
);
3895 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3896 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3900 gfc_conv_string_parameter (&lse
);
3901 gfc_conv_string_parameter (&rse
);
3903 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3904 rse
.string_length
, rse
.expr
,
3905 expr
->value
.op
.op1
->ts
.kind
,
3907 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3908 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3911 type
= gfc_typenode_for_spec (&expr
->ts
);
3915 /* The result of logical ops is always logical_type_node. */
3916 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3917 lse
.expr
, rse
.expr
);
3918 se
->expr
= convert (type
, tmp
);
3921 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3923 /* Add the post blocks. */
3924 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3925 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3928 /* If a string's length is one, we convert it to a single character. */
3931 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3935 || !tree_fits_uhwi_p (len
)
3936 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3939 if (TREE_INT_CST_LOW (len
) == 1)
3941 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3942 return build_fold_indirect_ref_loc (input_location
, str
);
3946 && TREE_CODE (str
) == ADDR_EXPR
3947 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3948 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3949 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3950 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3951 && TREE_INT_CST_LOW (len
) > 1
3952 && TREE_INT_CST_LOW (len
)
3953 == (unsigned HOST_WIDE_INT
)
3954 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3956 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3957 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3958 if (TREE_CODE (ret
) == INTEGER_CST
)
3960 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3961 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3962 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3964 for (i
= 1; i
< length
; i
++)
3977 conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3981 /* We used to modify the tree here. Now it is done earlier in
3982 the front-end, so we only check it here to avoid regressions. */
3983 if (sym
->backend_decl
)
3985 gcc_assert (TREE_CODE (TREE_TYPE (sym
->backend_decl
)) == INTEGER_TYPE
);
3986 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym
->backend_decl
)) == 1);
3987 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym
->backend_decl
)) == CHAR_TYPE_SIZE
);
3988 gcc_assert (DECL_BY_REFERENCE (sym
->backend_decl
) == 0);
3991 /* If we have a constant character expression, make it into an
3992 integer of type C char. */
3993 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3998 *expr
= gfc_get_int_expr (gfc_default_character_kind
, NULL
,
3999 (*expr
)->value
.character
.string
[0]);
4001 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
4003 if ((*expr
)->ref
== NULL
)
4005 se
->expr
= gfc_string_to_single_character
4006 (build_int_cst (integer_type_node
, 1),
4007 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
4009 ((*expr
)->symtree
->n
.sym
)),
4014 gfc_conv_variable (se
, *expr
);
4015 se
->expr
= gfc_string_to_single_character
4016 (build_int_cst (integer_type_node
, 1),
4017 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
4024 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4025 if STR is a string literal, otherwise return -1. */
4028 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
4031 && TREE_CODE (str
) == ADDR_EXPR
4032 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
4033 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
4034 && array_ref_low_bound (TREE_OPERAND (str
, 0))
4035 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
4036 && tree_fits_uhwi_p (len
)
4037 && tree_to_uhwi (len
) >= 1
4038 && tree_to_uhwi (len
)
4039 == (unsigned HOST_WIDE_INT
)
4040 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
4042 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
4043 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
4044 if (TREE_CODE (folded
) == INTEGER_CST
)
4046 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
4047 int length
= TREE_STRING_LENGTH (string_cst
);
4048 const char *ptr
= TREE_STRING_POINTER (string_cst
);
4050 for (; length
> 0; length
--)
4051 if (ptr
[length
- 1] != ' ')
4060 /* Helper to build a call to memcmp. */
4063 build_memcmp_call (tree s1
, tree s2
, tree n
)
4067 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
4068 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
4070 s1
= fold_convert (pvoid_type_node
, s1
);
4072 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
4073 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
4075 s2
= fold_convert (pvoid_type_node
, s2
);
4077 n
= fold_convert (size_type_node
, n
);
4079 tmp
= build_call_expr_loc (input_location
,
4080 builtin_decl_explicit (BUILT_IN_MEMCMP
),
4083 return fold_convert (integer_type_node
, tmp
);
4086 /* Compare two strings. If they are all single characters, the result is the
4087 subtraction of them. Otherwise, we build a library call. */
4090 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
4091 enum tree_code code
)
4097 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
4098 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
4100 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
4101 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
4103 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
4105 /* Deal with single character specially. */
4106 sc1
= fold_convert (integer_type_node
, sc1
);
4107 sc2
= fold_convert (integer_type_node
, sc2
);
4108 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
4112 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
4114 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
4116 /* If one string is a string literal with LEN_TRIM longer
4117 than the length of the second string, the strings
4119 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
4120 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
4121 return integer_one_node
;
4122 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
4123 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
4124 return integer_one_node
;
4127 /* We can compare via memcpy if the strings are known to be equal
4128 in length and they are
4130 - kind=4 and the comparison is for (in)equality. */
4132 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
4133 && tree_int_cst_equal (len1
, len2
)
4134 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
4139 chartype
= gfc_get_char_type (kind
);
4140 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
4141 fold_convert (TREE_TYPE(len1
),
4142 TYPE_SIZE_UNIT(chartype
)),
4144 return build_memcmp_call (str1
, str2
, tmp
);
4147 /* Build a call for the comparison. */
4149 fndecl
= gfor_fndecl_compare_string
;
4151 fndecl
= gfor_fndecl_compare_string_char4
;
4155 return build_call_expr_loc (input_location
, fndecl
, 4,
4156 len1
, str1
, len2
, str2
);
4160 /* Return the backend_decl for a procedure pointer component. */
4163 get_proc_ptr_comp (gfc_expr
*e
)
4169 gfc_init_se (&comp_se
, NULL
);
4170 e2
= gfc_copy_expr (e
);
4171 /* We have to restore the expr type later so that gfc_free_expr frees
4172 the exact same thing that was allocated.
4173 TODO: This is ugly. */
4174 old_type
= e2
->expr_type
;
4175 e2
->expr_type
= EXPR_VARIABLE
;
4176 gfc_conv_expr (&comp_se
, e2
);
4177 e2
->expr_type
= old_type
;
4179 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
4183 /* Convert a typebound function reference from a class object. */
4185 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
4190 if (!VAR_P (base_object
))
4192 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
4193 gfc_add_modify (&se
->pre
, var
, base_object
);
4195 se
->expr
= gfc_class_vptr_get (base_object
);
4196 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4198 while (ref
&& ref
->next
)
4200 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
4201 if (ref
->u
.c
.sym
->attr
.extension
)
4202 conv_parent_component_references (se
, ref
);
4203 gfc_conv_component_ref (se
, ref
);
4204 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
4209 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
,
4210 gfc_actual_arglist
*actual_args
)
4214 if (gfc_is_proc_ptr_comp (expr
))
4215 tmp
= get_proc_ptr_comp (expr
);
4216 else if (sym
->attr
.dummy
)
4218 tmp
= gfc_get_symbol_decl (sym
);
4219 if (sym
->attr
.proc_pointer
)
4220 tmp
= build_fold_indirect_ref_loc (input_location
,
4222 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
4223 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
4227 if (!sym
->backend_decl
)
4228 sym
->backend_decl
= gfc_get_extern_function_decl (sym
, actual_args
);
4230 TREE_USED (sym
->backend_decl
) = 1;
4232 tmp
= sym
->backend_decl
;
4234 if (sym
->attr
.cray_pointee
)
4236 /* TODO - make the cray pointee a pointer to a procedure,
4237 assign the pointer to it and use it for the call. This
4239 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
4240 gfc_get_symbol_decl (sym
->cp_pointer
));
4241 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4244 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
4246 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
4247 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4254 /* Initialize MAPPING. */
4257 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
4259 mapping
->syms
= NULL
;
4260 mapping
->charlens
= NULL
;
4264 /* Free all memory held by MAPPING (but not MAPPING itself). */
4267 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
4269 gfc_interface_sym_mapping
*sym
;
4270 gfc_interface_sym_mapping
*nextsym
;
4272 gfc_charlen
*nextcl
;
4274 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
4276 nextsym
= sym
->next
;
4277 sym
->new_sym
->n
.sym
->formal
= NULL
;
4278 gfc_free_symbol (sym
->new_sym
->n
.sym
);
4279 gfc_free_expr (sym
->expr
);
4280 free (sym
->new_sym
);
4283 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
4286 gfc_free_expr (cl
->length
);
4292 /* Return a copy of gfc_charlen CL. Add the returned structure to
4293 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4295 static gfc_charlen
*
4296 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
4299 gfc_charlen
*new_charlen
;
4301 new_charlen
= gfc_get_charlen ();
4302 new_charlen
->next
= mapping
->charlens
;
4303 new_charlen
->length
= gfc_copy_expr (cl
->length
);
4305 mapping
->charlens
= new_charlen
;
4310 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4311 array variable that can be used as the actual argument for dummy
4312 argument SYM. Add any initialization code to BLOCK. PACKED is as
4313 for gfc_get_nodesc_array_type and DATA points to the first element
4314 in the passed array. */
4317 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
4318 gfc_packed packed
, tree data
)
4323 type
= gfc_typenode_for_spec (&sym
->ts
);
4324 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
4325 !sym
->attr
.target
&& !sym
->attr
.pointer
4326 && !sym
->attr
.proc_pointer
);
4328 var
= gfc_create_var (type
, "ifm");
4329 gfc_add_modify (block
, var
, fold_convert (type
, data
));
4335 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4336 and offset of descriptorless array type TYPE given that it has the same
4337 size as DESC. Add any set-up code to BLOCK. */
4340 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
4347 offset
= gfc_index_zero_node
;
4348 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
4350 dim
= gfc_rank_cst
[n
];
4351 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
4352 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
4354 GFC_TYPE_ARRAY_LBOUND (type
, n
)
4355 = gfc_conv_descriptor_lbound_get (desc
, dim
);
4356 GFC_TYPE_ARRAY_UBOUND (type
, n
)
4357 = gfc_conv_descriptor_ubound_get (desc
, dim
);
4359 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
4361 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4362 gfc_array_index_type
,
4363 gfc_conv_descriptor_ubound_get (desc
, dim
),
4364 gfc_conv_descriptor_lbound_get (desc
, dim
));
4365 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4366 gfc_array_index_type
,
4367 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
4368 tmp
= gfc_evaluate_now (tmp
, block
);
4369 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
4371 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4372 GFC_TYPE_ARRAY_LBOUND (type
, n
),
4373 GFC_TYPE_ARRAY_STRIDE (type
, n
));
4374 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4375 gfc_array_index_type
, offset
, tmp
);
4377 offset
= gfc_evaluate_now (offset
, block
);
4378 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
4382 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4383 in SE. The caller may still use se->expr and se->string_length after
4384 calling this function. */
4387 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
4388 gfc_symbol
* sym
, gfc_se
* se
,
4391 gfc_interface_sym_mapping
*sm
;
4395 gfc_symbol
*new_sym
;
4397 gfc_symtree
*new_symtree
;
4399 /* Create a new symbol to represent the actual argument. */
4400 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
4401 new_sym
->ts
= sym
->ts
;
4402 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
4403 new_sym
->attr
.referenced
= 1;
4404 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
4405 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
4406 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
4407 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
4408 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
4409 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
4410 new_sym
->attr
.function
= sym
->attr
.function
;
4412 /* Ensure that the interface is available and that
4413 descriptors are passed for array actual arguments. */
4414 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4416 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
4417 new_sym
->attr
.always_explicit
4418 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
4421 /* Create a fake symtree for it. */
4423 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
4424 new_symtree
->n
.sym
= new_sym
;
4425 gcc_assert (new_symtree
== root
);
4427 /* Create a dummy->actual mapping. */
4428 sm
= XCNEW (gfc_interface_sym_mapping
);
4429 sm
->next
= mapping
->syms
;
4431 sm
->new_sym
= new_symtree
;
4432 sm
->expr
= gfc_copy_expr (expr
);
4435 /* Stabilize the argument's value. */
4436 if (!sym
->attr
.function
&& se
)
4437 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4439 if (sym
->ts
.type
== BT_CHARACTER
)
4441 /* Create a copy of the dummy argument's length. */
4442 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
4443 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
4445 /* If the length is specified as "*", record the length that
4446 the caller is passing. We should use the callee's length
4447 in all other cases. */
4448 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4450 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4451 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4458 /* Use the passed value as-is if the argument is a function. */
4459 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4462 /* If the argument is a pass-by-value scalar, use the value as is. */
4463 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
4466 /* If the argument is either a string or a pointer to a string,
4467 convert it to a boundless character type. */
4468 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4470 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4471 tmp
= build_pointer_type (tmp
);
4472 if (sym
->attr
.pointer
)
4473 value
= build_fold_indirect_ref_loc (input_location
,
4477 value
= fold_convert (tmp
, value
);
4480 /* If the argument is a scalar, a pointer to an array or an allocatable,
4482 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4483 value
= build_fold_indirect_ref_loc (input_location
,
4486 /* For character(*), use the actual argument's descriptor. */
4487 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4488 value
= build_fold_indirect_ref_loc (input_location
,
4491 /* If the argument is an array descriptor, use it to determine
4492 information about the actual argument's shape. */
4493 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4494 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4496 /* Get the actual argument's descriptor. */
4497 desc
= build_fold_indirect_ref_loc (input_location
,
4500 /* Create the replacement variable. */
4501 tmp
= gfc_conv_descriptor_data_get (desc
);
4502 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4505 /* Use DESC to work out the upper bounds, strides and offset. */
4506 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4509 /* Otherwise we have a packed array. */
4510 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4511 PACKED_FULL
, se
->expr
);
4513 new_sym
->backend_decl
= value
;
4517 /* Called once all dummy argument mappings have been added to MAPPING,
4518 but before the mapping is used to evaluate expressions. Pre-evaluate
4519 the length of each argument, adding any initialization code to PRE and
4520 any finalization code to POST. */
4523 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4524 stmtblock_t
* pre
, stmtblock_t
* post
)
4526 gfc_interface_sym_mapping
*sym
;
4530 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4531 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4532 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4534 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4535 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4536 gfc_init_se (&se
, NULL
);
4537 gfc_conv_expr (&se
, expr
);
4538 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4539 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4540 gfc_add_block_to_block (pre
, &se
.pre
);
4541 gfc_add_block_to_block (post
, &se
.post
);
4543 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4548 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4552 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4553 gfc_constructor_base base
)
4556 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4558 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4561 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4562 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4563 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4569 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4573 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4578 for (; ref
; ref
= ref
->next
)
4582 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4584 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4585 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4586 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4595 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4596 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4602 /* Convert intrinsic function calls into result expressions. */
4605 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4613 arg1
= expr
->value
.function
.actual
->expr
;
4614 if (expr
->value
.function
.actual
->next
)
4615 arg2
= expr
->value
.function
.actual
->next
->expr
;
4619 sym
= arg1
->symtree
->n
.sym
;
4621 if (sym
->attr
.dummy
)
4626 switch (expr
->value
.function
.isym
->id
)
4629 /* TODO figure out why this condition is necessary. */
4630 if (sym
->attr
.function
4631 && (arg1
->ts
.u
.cl
->length
== NULL
4632 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4633 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4636 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4639 case GFC_ISYM_LEN_TRIM
:
4640 new_expr
= gfc_copy_expr (arg1
);
4641 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4646 gfc_replace_expr (arg1
, new_expr
);
4650 if (!sym
->as
|| sym
->as
->rank
== 0)
4653 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4655 dup
= mpz_get_si (arg2
->value
.integer
);
4660 dup
= sym
->as
->rank
;
4664 for (; d
< dup
; d
++)
4668 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4670 gfc_free_expr (new_expr
);
4674 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4675 gfc_get_int_expr (gfc_default_integer_kind
,
4677 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4679 new_expr
= gfc_multiply (new_expr
, tmp
);
4685 case GFC_ISYM_LBOUND
:
4686 case GFC_ISYM_UBOUND
:
4687 /* TODO These implementations of lbound and ubound do not limit if
4688 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4690 if (!sym
->as
|| sym
->as
->rank
== 0)
4693 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4694 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4698 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4700 if (sym
->as
->lower
[d
])
4701 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4705 if (sym
->as
->upper
[d
])
4706 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4714 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4718 gfc_replace_expr (expr
, new_expr
);
4724 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4725 gfc_interface_mapping
* mapping
)
4727 gfc_formal_arglist
*f
;
4728 gfc_actual_arglist
*actual
;
4730 actual
= expr
->value
.function
.actual
;
4731 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4733 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4738 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4741 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4746 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4748 for (d
= 0; d
< as
->rank
; d
++)
4750 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4751 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4754 expr
->value
.function
.esym
->as
= as
;
4757 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4759 expr
->value
.function
.esym
->ts
.u
.cl
->length
4760 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4762 gfc_apply_interface_mapping_to_expr (mapping
,
4763 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4768 /* EXPR is a copy of an expression that appeared in the interface
4769 associated with MAPPING. Walk it recursively looking for references to
4770 dummy arguments that MAPPING maps to actual arguments. Replace each such
4771 reference with a reference to the associated actual argument. */
4774 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4777 gfc_interface_sym_mapping
*sym
;
4778 gfc_actual_arglist
*actual
;
4783 /* Copying an expression does not copy its length, so do that here. */
4784 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4786 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4787 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4790 /* Apply the mapping to any references. */
4791 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4793 /* ...and to the expression's symbol, if it has one. */
4794 /* TODO Find out why the condition on expr->symtree had to be moved into
4795 the loop rather than being outside it, as originally. */
4796 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4797 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4799 if (sym
->new_sym
->n
.sym
->backend_decl
)
4800 expr
->symtree
= sym
->new_sym
;
4802 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4805 /* ...and to subexpressions in expr->value. */
4806 switch (expr
->expr_type
)
4811 case EXPR_SUBSTRING
:
4815 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4816 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4820 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4821 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4823 if (expr
->value
.function
.esym
== NULL
4824 && expr
->value
.function
.isym
!= NULL
4825 && expr
->value
.function
.actual
4826 && expr
->value
.function
.actual
->expr
4827 && expr
->value
.function
.actual
->expr
->symtree
4828 && gfc_map_intrinsic_function (expr
, mapping
))
4831 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4832 if (sym
->old
== expr
->value
.function
.esym
)
4834 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4835 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4836 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4841 case EXPR_STRUCTURE
:
4842 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4856 /* Evaluate interface expression EXPR using MAPPING. Store the result
4860 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4861 gfc_se
* se
, gfc_expr
* expr
)
4863 expr
= gfc_copy_expr (expr
);
4864 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4865 gfc_conv_expr (se
, expr
);
4866 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4867 gfc_free_expr (expr
);
4871 /* Returns a reference to a temporary array into which a component of
4872 an actual argument derived type array is copied and then returned
4873 after the function call. */
4875 gfc_conv_subref_array_arg (gfc_se
*se
, gfc_expr
* expr
, int g77
,
4876 sym_intent intent
, bool formal_ptr
,
4877 const gfc_symbol
*fsym
, const char *proc_name
,
4878 gfc_symbol
*sym
, bool check_contiguous
)
4886 gfc_array_info
*info
;
4899 pass_optional
= fsym
&& fsym
->attr
.optional
&& sym
&& sym
->attr
.optional
;
4901 if (pass_optional
|| check_contiguous
)
4903 gfc_init_se (&work_se
, NULL
);
4909 if (gfc_option
.rtcheck
& GFC_RTCHECK_ARRAY_TEMPS
)
4911 /* We will create a temporary array, so let us warn. */
4914 if (fsym
&& proc_name
)
4915 msg
= xasprintf ("An array temporary was created for argument "
4916 "'%s' of procedure '%s'", fsym
->name
, proc_name
);
4918 msg
= xasprintf ("An array temporary was created");
4920 tmp
= build_int_cst (logical_type_node
, 1);
4921 gfc_trans_runtime_check (false, true, tmp
, &parmse
->pre
,
4926 gfc_init_se (&lse
, NULL
);
4927 gfc_init_se (&rse
, NULL
);
4929 /* Walk the argument expression. */
4930 rss
= gfc_walk_expr (expr
);
4932 gcc_assert (rss
!= gfc_ss_terminator
);
4934 /* Initialize the scalarizer. */
4935 gfc_init_loopinfo (&loop
);
4936 gfc_add_ss_to_loop (&loop
, rss
);
4938 /* Calculate the bounds of the scalarization. */
4939 gfc_conv_ss_startstride (&loop
);
4941 /* Build an ss for the temporary. */
4942 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4943 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4945 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4946 if (GFC_ARRAY_TYPE_P (base_type
)
4947 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4948 base_type
= gfc_get_element_type (base_type
);
4950 if (expr
->ts
.type
== BT_CLASS
)
4951 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4953 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4954 ? expr
->ts
.u
.cl
->backend_decl
4958 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4960 /* Associate the SS with the loop. */
4961 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4963 /* Setup the scalarizing loops. */
4964 gfc_conv_loop_setup (&loop
, &expr
->where
);
4966 /* Pass the temporary descriptor back to the caller. */
4967 info
= &loop
.temp_ss
->info
->data
.array
;
4968 parmse
->expr
= info
->descriptor
;
4970 /* Setup the gfc_se structures. */
4971 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4972 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4975 lse
.ss
= loop
.temp_ss
;
4976 gfc_mark_ss_chain_used (rss
, 1);
4977 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4979 /* Start the scalarized loop body. */
4980 gfc_start_scalarized_body (&loop
, &body
);
4982 /* Translate the expression. */
4983 gfc_conv_expr (&rse
, expr
);
4985 /* Reset the offset for the function call since the loop
4986 is zero based on the data pointer. Note that the temp
4987 comes first in the loop chain since it is added second. */
4988 if (gfc_is_class_array_function (expr
))
4990 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4991 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4992 gfc_index_zero_node
);
4995 gfc_conv_tmp_array_ref (&lse
);
4997 if (intent
!= INTENT_OUT
)
4999 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
5000 gfc_add_expr_to_block (&body
, tmp
);
5001 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5002 gfc_trans_scalarizing_loops (&loop
, &body
);
5006 /* Make sure that the temporary declaration survives by merging
5007 all the loop declarations into the current context. */
5008 for (n
= 0; n
< loop
.dimen
; n
++)
5010 gfc_merge_block_scope (&body
);
5011 body
= loop
.code
[loop
.order
[n
]];
5013 gfc_merge_block_scope (&body
);
5016 /* Add the post block after the second loop, so that any
5017 freeing of allocated memory is done at the right time. */
5018 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
5020 /**********Copy the temporary back again.*********/
5022 gfc_init_se (&lse
, NULL
);
5023 gfc_init_se (&rse
, NULL
);
5025 /* Walk the argument expression. */
5026 lss
= gfc_walk_expr (expr
);
5027 rse
.ss
= loop
.temp_ss
;
5030 /* Initialize the scalarizer. */
5031 gfc_init_loopinfo (&loop2
);
5032 gfc_add_ss_to_loop (&loop2
, lss
);
5034 dimen
= rse
.ss
->dimen
;
5036 /* Skip the write-out loop for this case. */
5037 if (gfc_is_class_array_function (expr
))
5038 goto class_array_fcn
;
5040 /* Calculate the bounds of the scalarization. */
5041 gfc_conv_ss_startstride (&loop2
);
5043 /* Setup the scalarizing loops. */
5044 gfc_conv_loop_setup (&loop2
, &expr
->where
);
5046 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
5047 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
5049 gfc_mark_ss_chain_used (lss
, 1);
5050 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
5052 /* Declare the variable to hold the temporary offset and start the
5053 scalarized loop body. */
5054 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
5055 gfc_start_scalarized_body (&loop2
, &body
);
5057 /* Build the offsets for the temporary from the loop variables. The
5058 temporary array has lbounds of zero and strides of one in all
5059 dimensions, so this is very simple. The offset is only computed
5060 outside the innermost loop, so the overall transfer could be
5061 optimized further. */
5062 info
= &rse
.ss
->info
->data
.array
;
5064 tmp_index
= gfc_index_zero_node
;
5065 for (n
= dimen
- 1; n
> 0; n
--)
5068 tmp
= rse
.loop
->loopvar
[n
];
5069 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5070 tmp
, rse
.loop
->from
[n
]);
5071 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5074 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
5075 gfc_array_index_type
,
5076 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
5077 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
5078 gfc_array_index_type
,
5079 tmp_str
, gfc_index_one_node
);
5081 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
5082 gfc_array_index_type
, tmp
, tmp_str
);
5085 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
5086 gfc_array_index_type
,
5087 tmp_index
, rse
.loop
->from
[0]);
5088 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
5090 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
5091 gfc_array_index_type
,
5092 rse
.loop
->loopvar
[0], offset
);
5094 /* Now use the offset for the reference. */
5095 tmp
= build_fold_indirect_ref_loc (input_location
,
5097 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
5099 if (expr
->ts
.type
== BT_CHARACTER
)
5100 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
5102 gfc_conv_expr (&lse
, expr
);
5104 gcc_assert (lse
.ss
== gfc_ss_terminator
);
5106 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
5107 gfc_add_expr_to_block (&body
, tmp
);
5109 /* Generate the copying loops. */
5110 gfc_trans_scalarizing_loops (&loop2
, &body
);
5112 /* Wrap the whole thing up by adding the second loop to the post-block
5113 and following it by the post-block of the first loop. In this way,
5114 if the temporary needs freeing, it is done after use! */
5115 if (intent
!= INTENT_IN
)
5117 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
5118 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
5123 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
5125 gfc_cleanup_loop (&loop
);
5126 gfc_cleanup_loop (&loop2
);
5128 /* Pass the string length to the argument expression. */
5129 if (expr
->ts
.type
== BT_CHARACTER
)
5130 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
5132 /* Determine the offset for pointer formal arguments and set the
5136 size
= gfc_index_one_node
;
5137 offset
= gfc_index_zero_node
;
5138 for (n
= 0; n
< dimen
; n
++)
5140 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
5142 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5143 gfc_array_index_type
, tmp
,
5144 gfc_index_one_node
);
5145 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
5149 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
5152 gfc_index_one_node
);
5153 size
= gfc_evaluate_now (size
, &parmse
->pre
);
5154 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5155 gfc_array_index_type
,
5157 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
5158 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5159 gfc_array_index_type
,
5160 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
5161 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5162 gfc_array_index_type
,
5163 tmp
, gfc_index_one_node
);
5164 size
= fold_build2_loc (input_location
, MULT_EXPR
,
5165 gfc_array_index_type
, size
, tmp
);
5168 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
5172 /* We want either the address for the data or the address of the descriptor,
5173 depending on the mode of passing array arguments. */
5175 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
5177 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
5179 /* Basically make this into
5190 pointer = parmse->expr;
5197 if (present && !contiguous)
5202 if (pass_optional
|| check_contiguous
)
5205 stmtblock_t else_block
;
5206 tree pre_stmts
, post_stmts
;
5209 tree present_var
= NULL_TREE
;
5210 tree cont_var
= NULL_TREE
;
5213 type
= TREE_TYPE (parmse
->expr
);
5214 if (POINTER_TYPE_P (type
) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
5215 type
= TREE_TYPE (type
);
5216 pointer
= gfc_create_var (type
, "arg_ptr");
5218 if (check_contiguous
)
5220 gfc_se cont_se
, array_se
;
5221 stmtblock_t if_block
, else_block
;
5222 tree if_stmt
, else_stmt
;
5226 cont_var
= gfc_create_var (boolean_type_node
, "contiguous");
5228 /* If the size is known to be one at compile-time, set
5229 cont_var to true unconditionally. This may look
5230 inelegant, but we're only doing this during
5231 optimization, so the statements will be optimized away,
5232 and this saves complexity here. */
5234 size_set
= gfc_array_size (expr
, &size
);
5235 if (size_set
&& mpz_cmp_ui (size
, 1) == 0)
5237 gfc_add_modify (&se
->pre
, cont_var
,
5238 build_one_cst (boolean_type_node
));
5242 /* cont_var = is_contiguous (expr); . */
5243 gfc_init_se (&cont_se
, parmse
);
5244 gfc_conv_is_contiguous_expr (&cont_se
, expr
);
5245 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->pre
);
5246 gfc_add_modify (&se
->pre
, cont_var
, cont_se
.expr
);
5247 gfc_add_block_to_block (&se
->pre
, &(&cont_se
)->post
);
5253 /* arrayse->expr = descriptor of a. */
5254 gfc_init_se (&array_se
, se
);
5255 gfc_conv_expr_descriptor (&array_se
, expr
);
5256 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->pre
);
5257 gfc_add_block_to_block (&se
->pre
, &(&array_se
)->post
);
5259 /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5260 gfc_init_block (&if_block
);
5261 if (GFC_DESCRIPTOR_TYPE_P (type
))
5262 gfc_add_modify (&if_block
, pointer
, array_se
.expr
);
5265 tmp
= gfc_conv_array_data (array_se
.expr
);
5266 tmp
= fold_convert (type
, tmp
);
5267 gfc_add_modify (&if_block
, pointer
, tmp
);
5269 if_stmt
= gfc_finish_block (&if_block
);
5271 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5272 gfc_init_block (&else_block
);
5273 gfc_add_block_to_block (&else_block
, &parmse
->pre
);
5274 tmp
= (GFC_DESCRIPTOR_TYPE_P (type
)
5275 ? build_fold_indirect_ref_loc (input_location
, parmse
->expr
)
5277 gfc_add_modify (&else_block
, pointer
, tmp
);
5278 else_stmt
= gfc_finish_block (&else_block
);
5280 /* And put the above into an if statement. */
5281 pre_stmts
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5282 gfc_likely (cont_var
,
5283 PRED_FORTRAN_CONTIGUOUS
),
5284 if_stmt
, else_stmt
);
5288 /* pointer = pramse->expr; . */
5289 gfc_add_modify (&parmse
->pre
, pointer
, parmse
->expr
);
5290 pre_stmts
= gfc_finish_block (&parmse
->pre
);
5295 present_var
= gfc_create_var (boolean_type_node
, "present");
5297 /* present_var = present(sym); . */
5298 tmp
= gfc_conv_expr_present (sym
);
5299 tmp
= fold_convert (boolean_type_node
, tmp
);
5300 gfc_add_modify (&se
->pre
, present_var
, tmp
);
5302 /* else_stmt = { pointer = NULL; } . */
5303 gfc_init_block (&else_block
);
5304 if (GFC_DESCRIPTOR_TYPE_P (type
))
5305 gfc_conv_descriptor_data_set (&else_block
, pointer
,
5308 gfc_add_modify (&else_block
, pointer
, build_int_cst (type
, 0));
5309 else_stmt
= gfc_finish_block (&else_block
);
5311 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5312 gfc_likely (present_var
,
5313 PRED_FORTRAN_ABSENT_DUMMY
),
5314 pre_stmts
, else_stmt
);
5315 gfc_add_expr_to_block (&se
->pre
, tmp
);
5318 gfc_add_expr_to_block (&se
->pre
, pre_stmts
);
5320 post_stmts
= gfc_finish_block (&parmse
->post
);
5322 /* Put together the post stuff, plus the optional
5324 if (check_contiguous
)
5327 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5329 build_zero_cst (boolean_type_node
));
5330 tmp
= gfc_unlikely (tmp
, PRED_FORTRAN_CONTIGUOUS
);
5334 tree present_likely
= gfc_likely (present_var
,
5335 PRED_FORTRAN_ABSENT_DUMMY
);
5336 post_cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
5337 boolean_type_node
, present_likely
,
5345 gcc_assert (pass_optional
);
5346 post_cond
= present_var
;
5349 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, post_cond
,
5350 post_stmts
, build_empty_stmt (input_location
));
5351 gfc_add_expr_to_block (&se
->post
, tmp
);
5352 if (GFC_DESCRIPTOR_TYPE_P (type
))
5354 type
= TREE_TYPE (parmse
->expr
);
5355 if (POINTER_TYPE_P (type
))
5357 pointer
= gfc_build_addr_expr (type
, pointer
);
5360 tmp
= gfc_likely (present_var
, PRED_FORTRAN_ABSENT_DUMMY
);
5361 pointer
= fold_build3_loc (input_location
, COND_EXPR
, type
,
5364 null_pointer_node
));
5368 gcc_assert (!pass_optional
);
5377 /* Generate the code for argument list functions. */
5380 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
5382 /* Pass by value for g77 %VAL(arg), pass the address
5383 indirectly for %LOC, else by reference. Thus %REF
5384 is a "do-nothing" and %LOC is the same as an F95
5386 if (strcmp (name
, "%VAL") == 0)
5387 gfc_conv_expr (se
, expr
);
5388 else if (strcmp (name
, "%LOC") == 0)
5390 gfc_conv_expr_reference (se
, expr
);
5391 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
5393 else if (strcmp (name
, "%REF") == 0)
5394 gfc_conv_expr_reference (se
, expr
);
5396 gfc_error ("Unknown argument list function at %L", &expr
->where
);
5400 /* This function tells whether the middle-end representation of the expression
5401 E given as input may point to data otherwise accessible through a variable
5403 It is assumed that the only expressions that may alias are variables,
5404 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5406 This function is used to decide whether freeing an expression's allocatable
5407 components is safe or should be avoided.
5409 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5410 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5411 is necessary because for array constructors, aliasing depends on how
5413 - If E is an array constructor used as argument to an elemental procedure,
5414 the array, which is generated through shallow copy by the scalarizer,
5415 is used directly and can alias the expressions it was copied from.
5416 - If E is an array constructor used as argument to a non-elemental
5417 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5418 the array as in the previous case, but then that array is used
5419 to initialize a new descriptor through deep copy. There is no alias
5420 possible in that case.
5421 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5425 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
5429 if (e
->expr_type
== EXPR_VARIABLE
)
5431 else if (e
->expr_type
== EXPR_FUNCTION
)
5433 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
5435 if (proc_ifc
->result
!= NULL
5436 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
5437 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
5438 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
5439 || proc_ifc
->result
->attr
.pointer
))
5444 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
5447 for (c
= gfc_constructor_first (e
->value
.constructor
);
5448 c
; c
= gfc_constructor_next (c
))
5450 && expr_may_alias_variables (c
->expr
, array_may_alias
))
5457 /* A helper function to set the dtype for unallocated or unassociated
5461 set_dtype_for_unallocated (gfc_se
*parmse
, gfc_expr
*e
)
5469 /* TODO Figure out how to handle optional dummies. */
5470 if (e
&& e
->expr_type
== EXPR_VARIABLE
5471 && e
->symtree
->n
.sym
->attr
.optional
)
5474 desc
= parmse
->expr
;
5475 if (desc
== NULL_TREE
)
5478 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
5479 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
5480 if (GFC_CLASS_TYPE_P (TREE_TYPE (desc
)))
5481 desc
= gfc_class_data_get (desc
);
5482 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
5485 gfc_init_block (&block
);
5486 tmp
= gfc_conv_descriptor_data_get (desc
);
5487 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5488 logical_type_node
, tmp
,
5489 build_int_cst (TREE_TYPE (tmp
), 0));
5490 tmp
= gfc_conv_descriptor_dtype (desc
);
5491 type
= gfc_get_element_type (TREE_TYPE (desc
));
5492 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5493 TREE_TYPE (tmp
), tmp
,
5494 gfc_get_dtype_rank_type (e
->rank
, type
));
5495 gfc_add_expr_to_block (&block
, tmp
);
5496 cond
= build3_v (COND_EXPR
, cond
,
5497 gfc_finish_block (&block
),
5498 build_empty_stmt (input_location
));
5499 gfc_add_expr_to_block (&parmse
->pre
, cond
);
5504 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5505 ISO_Fortran_binding array descriptors. */
5508 gfc_conv_gfc_desc_to_cfi_desc (gfc_se
*parmse
, gfc_expr
*e
, gfc_symbol
*fsym
)
5510 stmtblock_t block
, block2
;
5511 tree cfi
, gfc
, tmp
, tmp2
;
5512 tree present
= NULL
;
5513 tree gfc_strlen
= NULL
;
5517 if (fsym
->attr
.optional
5518 && e
->expr_type
== EXPR_VARIABLE
5519 && e
->symtree
->n
.sym
->attr
.optional
)
5520 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5522 gfc_init_block (&block
);
5524 /* Convert original argument to a tree. */
5525 gfc_init_se (&se
, NULL
);
5528 se
.want_pointer
= 1;
5529 gfc_conv_expr (&se
, e
);
5531 /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5532 if (!POINTER_TYPE_P (TREE_TYPE (gfc
)))
5533 gfc
= gfc_build_addr_expr (NULL
, gfc
);
5537 /* If the actual argument can be noncontiguous, copy-in/out is required,
5538 if the dummy has either the CONTIGUOUS attribute or is an assumed-
5539 length assumed-length/assumed-size CHARACTER array. */
5540 se
.force_no_tmp
= 1;
5541 if ((fsym
->attr
.contiguous
5542 || (fsym
->ts
.type
== BT_CHARACTER
&& !fsym
->ts
.u
.cl
->length
5543 && (fsym
->as
->type
== AS_ASSUMED_SIZE
5544 || fsym
->as
->type
== AS_EXPLICIT
)))
5545 && !gfc_is_simply_contiguous (e
, false, true))
5547 bool optional
= fsym
->attr
.optional
;
5548 fsym
->attr
.optional
= 0;
5549 gfc_conv_subref_array_arg (&se
, e
, false, fsym
->attr
.intent
,
5550 fsym
->attr
.pointer
, fsym
,
5551 fsym
->ns
->proc_name
->name
, NULL
,
5552 /* check_contiguous= */ true);
5553 fsym
->attr
.optional
= optional
;
5556 gfc_conv_expr_descriptor (&se
, e
);
5558 /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5559 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5560 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5561 While sm is fine as it uses span*stride and not elem_len. */
5562 if (POINTER_TYPE_P (TREE_TYPE (gfc
)))
5563 gfc
= build_fold_indirect_ref_loc (input_location
, gfc
);
5564 else if (is_subref_array (e
) && e
->ts
.type
!= BT_CHARACTER
)
5565 gfc_get_dataptr_offset (&se
.pre
, gfc
, gfc
, NULL
, true, e
);
5567 if (e
->ts
.type
== BT_CHARACTER
)
5569 if (se
.string_length
)
5570 gfc_strlen
= se
.string_length
;
5571 else if (e
->ts
.u
.cl
->backend_decl
)
5572 gfc_strlen
= e
->ts
.u
.cl
->backend_decl
;
5576 gfc_add_block_to_block (&block
, &se
.pre
);
5578 /* Create array decriptor and set version, rank, attribute, type. */
5579 cfi
= gfc_create_var (gfc_get_cfi_type (e
->rank
< 0
5580 ? GFC_MAX_DIMENSIONS
: e
->rank
,
5582 /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5583 if (fsym
->attr
.dimension
&& fsym
->as
->type
== AS_ASSUMED_RANK
)
5585 tmp
= gfc_get_cfi_type (-1, !fsym
->attr
.pointer
&& !fsym
->attr
.target
);
5586 tmp
= build_pointer_type (tmp
);
5587 parmse
->expr
= cfi
= gfc_build_addr_expr (tmp
, cfi
);
5588 cfi
= build_fold_indirect_ref_loc (input_location
, cfi
);
5591 parmse
->expr
= gfc_build_addr_expr (NULL
, cfi
);
5593 tmp
= gfc_get_cfi_desc_version (cfi
);
5594 gfc_add_modify (&block
, tmp
,
5595 build_int_cst (TREE_TYPE (tmp
), CFI_VERSION
));
5597 rank
= fold_convert (signed_char_type_node
, gfc_conv_descriptor_rank (gfc
));
5599 rank
= build_int_cst (signed_char_type_node
, e
->rank
);
5600 tmp
= gfc_get_cfi_desc_rank (cfi
);
5601 gfc_add_modify (&block
, tmp
, rank
);
5602 int itype
= CFI_type_other
;
5603 if (e
->ts
.f90_type
== BT_VOID
)
5604 itype
= (e
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
5605 ? CFI_type_cfunptr
: CFI_type_cptr
);
5613 itype
= CFI_type_from_type_kind (e
->ts
.type
, e
->ts
.kind
);
5616 itype
= CFI_type_from_type_kind (CFI_type_Character
, e
->ts
.kind
);
5619 itype
= CFI_type_struct
;
5622 itype
= (e
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
5623 ? CFI_type_cfunptr
: CFI_type_cptr
);
5626 itype
= CFI_type_other
; // FIXME: Or CFI_type_cptr ?
5634 // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5638 tmp
= gfc_get_cfi_desc_type (cfi
);
5639 gfc_add_modify (&block
, tmp
,
5640 build_int_cst (TREE_TYPE (tmp
), itype
));
5642 int attr
= CFI_attribute_other
;
5643 if (fsym
->attr
.pointer
)
5644 attr
= CFI_attribute_pointer
;
5645 else if (fsym
->attr
.allocatable
)
5646 attr
= CFI_attribute_allocatable
;
5647 tmp
= gfc_get_cfi_desc_attribute (cfi
);
5648 gfc_add_modify (&block
, tmp
,
5649 build_int_cst (TREE_TYPE (tmp
), attr
));
5653 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5654 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), gfc
));
5658 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5659 tmp2
= gfc_conv_descriptor_data_get (gfc
);
5660 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
5663 /* Set elem_len if known - must be before the next if block.
5664 Note that allocatable implies 'len=:'. */
5665 if (e
->ts
.type
!= BT_ASSUMED
&& e
->ts
.type
!= BT_CHARACTER
)
5667 /* Length is known at compile time; use use 'block' for it. */
5668 tmp
= size_in_bytes (gfc_typenode_for_spec (&e
->ts
));
5669 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5670 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5673 /* When allocatable + intent out, free the cfi descriptor. */
5674 if (fsym
->attr
.allocatable
&& fsym
->attr
.intent
== INTENT_OUT
)
5676 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5677 tree call
= builtin_decl_explicit (BUILT_IN_FREE
);
5678 call
= build_call_expr_loc (input_location
, call
, 1, tmp
);
5679 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
5680 gfc_add_modify (&block
, tmp
,
5681 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5685 /* If not unallocated/unassociated. */
5686 gfc_init_block (&block2
);
5688 /* Set elem_len, which may be only known at run time. */
5689 if (e
->ts
.type
== BT_CHARACTER
)
5691 gcc_assert (gfc_strlen
);
5693 if (e
->ts
.kind
!= 1)
5694 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5695 gfc_charlen_type_node
, tmp
,
5696 build_int_cst (gfc_charlen_type_node
,
5698 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5699 gfc_add_modify (&block2
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5701 else if (e
->ts
.type
== BT_ASSUMED
)
5703 tmp
= gfc_conv_descriptor_elem_len (gfc
);
5704 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
5705 gfc_add_modify (&block2
, tmp2
, fold_convert (TREE_TYPE (tmp2
), tmp
));
5708 if (e
->ts
.type
== BT_ASSUMED
)
5710 /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5711 an CFI descriptor. Use the type in the descritor as it provide
5712 mode information. (Quality of implementation feature.) */
5714 tree ctype
= gfc_get_cfi_desc_type (cfi
);
5715 tree type
= fold_convert (TREE_TYPE (ctype
),
5716 gfc_conv_descriptor_type (gfc
));
5717 tree kind
= fold_convert (TREE_TYPE (ctype
),
5718 gfc_conv_descriptor_elem_len (gfc
));
5719 kind
= fold_build2_loc (input_location
, LSHIFT_EXPR
, TREE_TYPE (type
),
5720 kind
, build_int_cst (TREE_TYPE (type
),
5721 CFI_type_kind_shift
));
5723 /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5724 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5725 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5726 build_int_cst (TREE_TYPE (type
), BT_VOID
));
5727 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, ctype
,
5728 build_int_cst (TREE_TYPE (type
), CFI_type_cptr
));
5729 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5731 build_int_cst (TREE_TYPE (type
), CFI_type_other
));
5732 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5734 /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5735 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5736 build_int_cst (TREE_TYPE (type
), BT_DERIVED
));
5737 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, ctype
,
5738 build_int_cst (TREE_TYPE (type
), CFI_type_struct
));
5739 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5741 /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5742 /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5743 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5744 build_int_cst (TREE_TYPE (type
), BT_CHARACTER
));
5745 tmp
= build_int_cst (TREE_TYPE (type
),
5746 CFI_type_from_type_kind (CFI_type_Character
, 1));
5747 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5749 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5751 /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5752 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5753 build_int_cst (TREE_TYPE (type
), BT_COMPLEX
));
5754 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (type
),
5755 kind
, build_int_cst (TREE_TYPE (type
), 2));
5756 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (type
), tmp
,
5757 build_int_cst (TREE_TYPE (type
),
5759 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5761 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5763 /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5764 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5765 build_int_cst (TREE_TYPE (type
), BT_INTEGER
));
5766 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5767 build_int_cst (TREE_TYPE (type
), BT_LOGICAL
));
5768 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
5770 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, type
,
5771 build_int_cst (TREE_TYPE (type
), BT_REAL
));
5772 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
5774 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (type
),
5776 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5778 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
5780 gfc_add_expr_to_block (&block2
, tmp2
);
5785 /* Loop: for (i = 0; i < rank; ++i). */
5786 tree idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
5788 stmtblock_t loop_body
;
5789 gfc_init_block (&loop_body
);
5790 /* cfi->dim[i].lower_bound = (allocatable/pointer)
5791 ? gfc->dim[i].lbound : 0 */
5792 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5793 tmp
= gfc_conv_descriptor_lbound_get (gfc
, idx
);
5795 tmp
= gfc_index_zero_node
;
5796 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_lbound (cfi
, idx
), tmp
);
5797 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5798 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5799 gfc_conv_descriptor_ubound_get (gfc
, idx
),
5800 gfc_conv_descriptor_lbound_get (gfc
, idx
));
5801 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5802 tmp
, gfc_index_one_node
);
5803 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
5804 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5805 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5806 gfc_conv_descriptor_stride_get (gfc
, idx
),
5807 gfc_conv_descriptor_span_get (gfc
));
5808 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_sm (cfi
, idx
), tmp
);
5810 /* Generate loop. */
5811 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 0),
5812 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
5813 gfc_finish_block (&loop_body
));
5815 if (e
->expr_type
== EXPR_VARIABLE
5817 && e
->ref
->u
.ar
.type
== AR_FULL
5818 && e
->symtree
->n
.sym
->attr
.dummy
5819 && e
->symtree
->n
.sym
->as
5820 && e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
)
5822 tmp
= gfc_get_cfi_dim_extent (cfi
, gfc_rank_cst
[e
->rank
-1]),
5823 gfc_add_modify (&block2
, tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
5827 if (fsym
->attr
.allocatable
|| fsym
->attr
.pointer
)
5829 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
5830 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5831 tmp
, null_pointer_node
);
5832 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
5833 build_empty_stmt (input_location
));
5834 gfc_add_expr_to_block (&block
, tmp
);
5837 gfc_add_block_to_block (&block
, &block2
);
5843 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
5844 TREE_TYPE (parmse
->expr
),
5845 present
, parmse
->expr
, null_pointer_node
);
5846 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
),
5847 build_empty_stmt (input_location
));
5848 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
5851 gfc_add_block_to_block (&parmse
->pre
, &block
);
5853 gfc_init_block (&block
);
5855 if ((!fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
)
5856 || fsym
->attr
.intent
== INTENT_IN
)
5859 gfc_init_block (&block2
);
5862 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5863 gfc_add_modify (&block
, gfc
, fold_convert (TREE_TYPE (gfc
), tmp
));
5867 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
5868 gfc_conv_descriptor_data_set (&block
, gfc
, tmp
);
5870 if (fsym
->attr
.allocatable
)
5872 /* gfc->span = cfi->elem_len. */
5873 tmp
= fold_convert (gfc_array_index_type
,
5874 gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]));
5878 /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5879 ? cfi->dim[0].sm : cfi->elem_len). */
5880 tmp
= gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]);
5881 tmp2
= fold_convert (gfc_array_index_type
,
5882 gfc_get_cfi_desc_elem_len (cfi
));
5883 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
5884 gfc_array_index_type
, tmp
, tmp2
);
5885 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5886 tmp
, gfc_index_zero_node
);
5887 tmp
= build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, tmp
,
5888 gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]), tmp2
);
5890 gfc_conv_descriptor_span_set (&block2
, gfc
, tmp
);
5892 /* Calculate offset + set lbound, ubound and stride. */
5893 gfc_conv_descriptor_offset_set (&block2
, gfc
, gfc_index_zero_node
);
5894 /* Loop: for (i = 0; i < rank; ++i). */
5895 tree idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
5897 stmtblock_t loop_body
;
5898 gfc_init_block (&loop_body
);
5899 /* gfc->dim[i].lbound = ... */
5900 tmp
= gfc_get_cfi_dim_lbound (cfi
, idx
);
5901 gfc_conv_descriptor_lbound_set (&loop_body
, gfc
, idx
, tmp
);
5903 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
5904 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5905 gfc_conv_descriptor_lbound_get (gfc
, idx
),
5906 gfc_index_one_node
);
5907 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5908 gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
5909 gfc_conv_descriptor_ubound_set (&loop_body
, gfc
, idx
, tmp
);
5911 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
5912 tmp
= gfc_get_cfi_dim_sm (cfi
, idx
);
5913 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5914 gfc_array_index_type
, tmp
,
5915 fold_convert (gfc_array_index_type
,
5916 gfc_get_cfi_desc_elem_len (cfi
)));
5917 gfc_conv_descriptor_stride_set (&loop_body
, gfc
, idx
, tmp
);
5919 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
5920 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5921 gfc_conv_descriptor_stride_get (gfc
, idx
),
5922 gfc_conv_descriptor_lbound_get (gfc
, idx
));
5923 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5924 gfc_conv_descriptor_offset_get (gfc
), tmp
);
5925 gfc_conv_descriptor_offset_set (&loop_body
, gfc
, tmp
);
5926 /* Generate loop. */
5927 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 0),
5928 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
5929 gfc_finish_block (&loop_body
));
5932 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
5934 tmp
= fold_convert (gfc_charlen_type_node
,
5935 gfc_get_cfi_desc_elem_len (cfi
));
5936 if (e
->ts
.kind
!= 1)
5937 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
5938 gfc_charlen_type_node
, tmp
,
5939 build_int_cst (gfc_charlen_type_node
,
5941 gfc_add_modify (&block2
, gfc_strlen
, tmp
);
5944 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
5945 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5946 tmp
, null_pointer_node
);
5947 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
5948 build_empty_stmt (input_location
));
5949 gfc_add_expr_to_block (&block
, tmp
);
5952 gfc_add_block_to_block (&block
, &se
.post
);
5953 if (present
&& block
.head
)
5955 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
),
5956 build_empty_stmt (input_location
));
5957 gfc_add_expr_to_block (&parmse
->post
, tmp
);
5959 else if (block
.head
)
5960 gfc_add_block_to_block (&parmse
->post
, &block
);
5964 /* Generate code for a procedure call. Note can return se->post != NULL.
5965 If se->direct_byref is set then se->expr contains the return parameter.
5966 Return nonzero, if the call has alternate specifiers.
5967 'expr' is only needed for procedure pointer components. */
5970 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
5971 gfc_actual_arglist
* args
, gfc_expr
* expr
,
5972 vec
<tree
, va_gc
> *append_args
)
5974 gfc_interface_mapping mapping
;
5975 vec
<tree
, va_gc
> *arglist
;
5976 vec
<tree
, va_gc
> *retargs
;
5980 gfc_array_info
*info
;
5987 vec
<tree
, va_gc
> *stringargs
;
5988 vec
<tree
, va_gc
> *optionalargs
;
5990 gfc_formal_arglist
*formal
;
5991 gfc_actual_arglist
*arg
;
5992 int has_alternate_specifier
= 0;
5993 bool need_interface_mapping
;
6001 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
6002 gfc_component
*comp
= NULL
;
6009 optionalargs
= NULL
;
6014 comp
= gfc_get_proc_ptr_comp (expr
);
6016 bool elemental_proc
= (comp
6017 && comp
->ts
.interface
6018 && comp
->ts
.interface
->attr
.elemental
)
6019 || (comp
&& comp
->attr
.elemental
)
6020 || sym
->attr
.elemental
;
6024 if (!elemental_proc
)
6026 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
6027 if (se
->ss
->info
->useflags
)
6029 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
6030 && sym
->result
->attr
.dimension
)
6031 || (comp
&& comp
->attr
.dimension
)
6032 || gfc_is_class_array_function (expr
));
6033 gcc_assert (se
->loop
!= NULL
);
6034 /* Access the previously obtained result. */
6035 gfc_conv_tmp_array_ref (se
);
6039 info
= &se
->ss
->info
->data
.array
;
6044 gfc_init_block (&post
);
6045 gfc_init_interface_mapping (&mapping
);
6048 formal
= gfc_sym_get_dummy_args (sym
);
6049 need_interface_mapping
= sym
->attr
.dimension
||
6050 (sym
->ts
.type
== BT_CHARACTER
6051 && sym
->ts
.u
.cl
->length
6052 && sym
->ts
.u
.cl
->length
->expr_type
6057 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
6058 need_interface_mapping
= comp
->attr
.dimension
||
6059 (comp
->ts
.type
== BT_CHARACTER
6060 && comp
->ts
.u
.cl
->length
6061 && comp
->ts
.u
.cl
->length
->expr_type
6065 base_object
= NULL_TREE
;
6066 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6067 is the third and fourth argument to such a function call a value
6068 denoting the number of elements to copy (i.e., most of the time the
6069 length of a deferred length string). */
6070 ulim_copy
= (formal
== NULL
)
6071 && UNLIMITED_POLY (sym
)
6072 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
6074 /* Evaluate the arguments. */
6075 for (arg
= args
, argc
= 0; arg
!= NULL
;
6076 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
6078 bool finalized
= false;
6079 tree derived_array
= NULL_TREE
;
6082 fsym
= formal
? formal
->sym
: NULL
;
6083 parm_kind
= MISSING
;
6085 /* If the procedure requires an explicit interface, the actual
6086 argument is passed according to the corresponding formal
6087 argument. If the corresponding formal argument is a POINTER,
6088 ALLOCATABLE or assumed shape, we do not use g77's calling
6089 convention, and pass the address of the array descriptor
6090 instead. Otherwise we use g77's calling convention, in other words
6091 pass the array data pointer without descriptor. */
6092 bool nodesc_arg
= fsym
!= NULL
6093 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
6095 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
6096 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
6098 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
6100 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
6102 /* Class array expressions are sometimes coming completely unadorned
6103 with either arrayspec or _data component. Correct that here.
6104 OOP-TODO: Move this to the frontend. */
6105 if (e
&& e
->expr_type
== EXPR_VARIABLE
6107 && e
->ts
.type
== BT_CLASS
6108 && (CLASS_DATA (e
)->attr
.codimension
6109 || CLASS_DATA (e
)->attr
.dimension
))
6111 gfc_typespec temp_ts
= e
->ts
;
6112 gfc_add_class_array_ref (e
);
6118 if (se
->ignore_optional
)
6120 /* Some intrinsics have already been resolved to the correct
6124 else if (arg
->label
)
6126 has_alternate_specifier
= 1;
6131 gfc_init_se (&parmse
, NULL
);
6133 /* For scalar arguments with VALUE attribute which are passed by
6134 value, pass "0" and a hidden argument gives the optional
6136 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
6137 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
6138 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
6140 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
6142 vec_safe_push (optionalargs
, boolean_false_node
);
6146 /* Pass a NULL pointer for an absent arg. */
6147 parmse
.expr
= null_pointer_node
;
6148 gfc_dummy_arg
* const dummy_arg
= arg
->associated_dummy
;
6150 && gfc_dummy_arg_get_typespec (*dummy_arg
).type
6152 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
6157 else if (arg
->expr
->expr_type
== EXPR_NULL
6158 && fsym
&& !fsym
->attr
.pointer
6159 && (fsym
->ts
.type
!= BT_CLASS
6160 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
6162 /* Pass a NULL pointer to denote an absent arg. */
6163 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
6164 && (fsym
->ts
.type
!= BT_CLASS
6165 || !CLASS_DATA (fsym
)->attr
.allocatable
));
6166 gfc_init_se (&parmse
, NULL
);
6167 parmse
.expr
= null_pointer_node
;
6168 if (arg
->associated_dummy
6169 && gfc_dummy_arg_get_typespec (*arg
->associated_dummy
).type
6171 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
6173 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
6174 && e
->ts
.type
== BT_DERIVED
)
6176 /* The derived type needs to be converted to a temporary
6178 gfc_init_se (&parmse
, se
);
6179 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
6181 && e
->expr_type
== EXPR_VARIABLE
6182 && e
->symtree
->n
.sym
->attr
.optional
,
6183 CLASS_DATA (fsym
)->attr
.class_pointer
6184 || CLASS_DATA (fsym
)->attr
.allocatable
,
6187 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
6188 && e
->ts
.type
!= BT_PROCEDURE
6189 && (gfc_expr_attr (e
).flavor
!= FL_PROCEDURE
6190 || gfc_expr_attr (e
).proc
!= PROC_UNKNOWN
))
6192 /* The intrinsic type needs to be converted to a temporary
6193 CLASS object for the unlimited polymorphic formal. */
6194 gfc_find_vtab (&e
->ts
);
6195 gfc_init_se (&parmse
, se
);
6196 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
6199 else if (se
->ss
&& se
->ss
->info
->useflags
)
6205 /* An elemental function inside a scalarized loop. */
6206 gfc_init_se (&parmse
, se
);
6207 parm_kind
= ELEMENTAL
;
6209 /* When no fsym is present, ulim_copy is set and this is a third or
6210 fourth argument, use call-by-value instead of by reference to
6211 hand the length properties to the copy routine (i.e., most of the
6212 time this will be a call to a __copy_character_* routine where the
6213 third and fourth arguments are the lengths of a deferred length
6215 if ((fsym
&& fsym
->attr
.value
)
6216 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
6217 gfc_conv_expr (&parmse
, e
);
6219 gfc_conv_expr_reference (&parmse
, e
);
6221 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
6222 && e
->expr_type
== EXPR_FUNCTION
)
6223 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
6226 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
6227 && gfc_is_class_container_ref (e
))
6229 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6231 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
6232 && e
->symtree
->n
.sym
->attr
.optional
)
6234 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6235 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
6236 TREE_TYPE (parmse
.expr
),
6238 fold_convert (TREE_TYPE (parmse
.expr
),
6239 null_pointer_node
));
6243 /* If we are passing an absent array as optional dummy to an
6244 elemental procedure, make sure that we pass NULL when the data
6245 pointer is NULL. We need this extra conditional because of
6246 scalarization which passes arrays elements to the procedure,
6247 ignoring the fact that the array can be absent/unallocated/... */
6248 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
6250 tree descriptor_data
;
6252 descriptor_data
= ss
->info
->data
.array
.data
;
6253 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
6255 fold_convert (TREE_TYPE (descriptor_data
),
6256 null_pointer_node
));
6258 = fold_build3_loc (input_location
, COND_EXPR
,
6259 TREE_TYPE (parmse
.expr
),
6260 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
6261 fold_convert (TREE_TYPE (parmse
.expr
),
6266 /* The scalarizer does not repackage the reference to a class
6267 array - instead it returns a pointer to the data element. */
6268 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
6269 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
6270 fsym
->attr
.intent
!= INTENT_IN
6271 && (CLASS_DATA (fsym
)->attr
.class_pointer
6272 || CLASS_DATA (fsym
)->attr
.allocatable
),
6274 && e
->expr_type
== EXPR_VARIABLE
6275 && e
->symtree
->n
.sym
->attr
.optional
,
6276 CLASS_DATA (fsym
)->attr
.class_pointer
6277 || CLASS_DATA (fsym
)->attr
.allocatable
);
6284 gfc_init_se (&parmse
, NULL
);
6286 /* Check whether the expression is a scalar or not; we cannot use
6287 e->rank as it can be nonzero for functions arguments. */
6288 argss
= gfc_walk_expr (e
);
6289 scalar
= argss
== gfc_ss_terminator
;
6291 gfc_free_ss_chain (argss
);
6293 /* Special handling for passing scalar polymorphic coarrays;
6294 otherwise one passes "class->_data.data" instead of "&class". */
6295 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
6296 && fsym
&& fsym
->ts
.type
== BT_CLASS
6297 && CLASS_DATA (fsym
)->attr
.codimension
6298 && !CLASS_DATA (fsym
)->attr
.dimension
)
6300 gfc_add_class_array_ref (e
);
6301 parmse
.want_coarray
= 1;
6305 /* A scalar or transformational function. */
6308 if (e
->expr_type
== EXPR_VARIABLE
6309 && e
->symtree
->n
.sym
->attr
.cray_pointee
6310 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
6312 /* The Cray pointer needs to be converted to a pointer to
6313 a type given by the expression. */
6314 gfc_conv_expr (&parmse
, e
);
6315 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
6316 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
6317 parmse
.expr
= convert (type
, tmp
);
6320 else if (sym
->attr
.is_bind_c
&& e
&& is_CFI_desc (fsym
, NULL
))
6321 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6322 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6324 else if (fsym
&& fsym
->attr
.value
)
6326 if (fsym
->ts
.type
== BT_CHARACTER
6327 && fsym
->ts
.is_c_interop
6328 && fsym
->ns
->proc_name
!= NULL
6329 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
6332 conv_scalar_char_value (fsym
, &parmse
, &e
);
6333 if (parmse
.expr
== NULL
)
6334 gfc_conv_expr (&parmse
, e
);
6338 gfc_conv_expr (&parmse
, e
);
6339 if (fsym
->attr
.optional
6340 && fsym
->ts
.type
!= BT_CLASS
6341 && fsym
->ts
.type
!= BT_DERIVED
)
6343 if (e
->expr_type
!= EXPR_VARIABLE
6344 || !e
->symtree
->n
.sym
->attr
.optional
6346 vec_safe_push (optionalargs
, boolean_true_node
);
6349 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6350 if (!e
->symtree
->n
.sym
->attr
.value
)
6352 = fold_build3_loc (input_location
, COND_EXPR
,
6353 TREE_TYPE (parmse
.expr
),
6355 fold_convert (TREE_TYPE (parmse
.expr
),
6356 integer_zero_node
));
6358 vec_safe_push (optionalargs
,
6359 fold_convert (boolean_type_node
,
6366 else if (arg
->name
&& arg
->name
[0] == '%')
6367 /* Argument list functions %VAL, %LOC and %REF are signalled
6368 through arg->name. */
6369 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
6370 else if ((e
->expr_type
== EXPR_FUNCTION
)
6371 && ((e
->value
.function
.esym
6372 && e
->value
.function
.esym
->result
->attr
.pointer
)
6373 || (!e
->value
.function
.esym
6374 && e
->symtree
->n
.sym
->attr
.pointer
))
6375 && fsym
&& fsym
->attr
.target
)
6376 /* Make sure the function only gets called once. */
6377 gfc_conv_expr_reference (&parmse
, e
, false);
6378 else if (e
->expr_type
== EXPR_FUNCTION
6379 && e
->symtree
->n
.sym
->result
6380 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
6381 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
6383 /* Functions returning procedure pointers. */
6384 gfc_conv_expr (&parmse
, e
);
6385 if (fsym
&& fsym
->attr
.proc_pointer
)
6386 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6391 if (e
->ts
.type
== BT_CLASS
&& fsym
6392 && fsym
->ts
.type
== BT_CLASS
6393 && (!CLASS_DATA (fsym
)->as
6394 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
6395 && CLASS_DATA (e
)->attr
.codimension
)
6397 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
6398 gcc_assert (!CLASS_DATA (fsym
)->as
);
6399 gfc_add_class_array_ref (e
);
6400 parmse
.want_coarray
= 1;
6401 gfc_conv_expr_reference (&parmse
, e
);
6402 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
6404 && e
->expr_type
== EXPR_VARIABLE
);
6406 else if (e
->ts
.type
== BT_CLASS
&& fsym
6407 && fsym
->ts
.type
== BT_CLASS
6408 && !CLASS_DATA (fsym
)->as
6409 && !CLASS_DATA (e
)->as
6410 && strcmp (fsym
->ts
.u
.derived
->name
,
6411 e
->ts
.u
.derived
->name
))
6413 type
= gfc_typenode_for_spec (&fsym
->ts
);
6414 var
= gfc_create_var (type
, fsym
->name
);
6415 gfc_conv_expr (&parmse
, e
);
6416 if (fsym
->attr
.optional
6417 && e
->expr_type
== EXPR_VARIABLE
6418 && e
->symtree
->n
.sym
->attr
.optional
)
6422 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6423 cond
= fold_build2_loc (input_location
, NE_EXPR
,
6424 logical_type_node
, tmp
,
6425 fold_convert (TREE_TYPE (tmp
),
6426 null_pointer_node
));
6427 gfc_start_block (&block
);
6428 gfc_add_modify (&block
, var
,
6429 fold_build1_loc (input_location
,
6431 type
, parmse
.expr
));
6432 gfc_add_expr_to_block (&parmse
.pre
,
6433 fold_build3_loc (input_location
,
6434 COND_EXPR
, void_type_node
,
6435 cond
, gfc_finish_block (&block
),
6436 build_empty_stmt (input_location
)));
6437 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6438 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
6439 TREE_TYPE (parmse
.expr
),
6441 fold_convert (TREE_TYPE (parmse
.expr
),
6442 null_pointer_node
));
6446 /* Since the internal representation of unlimited
6447 polymorphic expressions includes an extra field
6448 that other class objects do not, a cast to the
6449 formal type does not work. */
6450 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
6454 /* Set the _data field. */
6455 tmp
= gfc_class_data_get (var
);
6456 efield
= fold_convert (TREE_TYPE (tmp
),
6457 gfc_class_data_get (parmse
.expr
));
6458 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6460 /* Set the _vptr field. */
6461 tmp
= gfc_class_vptr_get (var
);
6462 efield
= fold_convert (TREE_TYPE (tmp
),
6463 gfc_class_vptr_get (parmse
.expr
));
6464 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
6466 /* Set the _len field. */
6467 tmp
= gfc_class_len_get (var
);
6468 gfc_add_modify (&parmse
.pre
, tmp
,
6469 build_int_cst (TREE_TYPE (tmp
), 0));
6473 tmp
= fold_build1_loc (input_location
,
6476 gfc_add_modify (&parmse
.pre
, var
, tmp
);
6479 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6485 add_clobber
= fsym
&& fsym
->attr
.intent
== INTENT_OUT
6486 && !fsym
->attr
.allocatable
&& !fsym
->attr
.pointer
6487 && e
->symtree
&& e
->symtree
->n
.sym
6488 && !e
->symtree
->n
.sym
->attr
.dimension
6489 && !e
->symtree
->n
.sym
->attr
.pointer
6490 && !e
->symtree
->n
.sym
->attr
.allocatable
6492 && !e
->symtree
->n
.sym
->attr
.dummy
6493 /* FIXME - PR 87395 and PR 41453 */
6494 && e
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
6495 && !e
->symtree
->n
.sym
->attr
.associate_var
6496 && e
->ts
.type
!= BT_CHARACTER
&& e
->ts
.type
!= BT_DERIVED
6497 && e
->ts
.type
!= BT_CLASS
&& !sym
->attr
.elemental
;
6499 gfc_conv_expr_reference (&parmse
, e
, add_clobber
);
6501 /* Catch base objects that are not variables. */
6502 if (e
->ts
.type
== BT_CLASS
6503 && e
->expr_type
!= EXPR_VARIABLE
6504 && expr
&& e
== expr
->base_expr
)
6505 base_object
= build_fold_indirect_ref_loc (input_location
,
6508 /* A class array element needs converting back to be a
6509 class object, if the formal argument is a class object. */
6510 if (fsym
&& fsym
->ts
.type
== BT_CLASS
6511 && e
->ts
.type
== BT_CLASS
6512 && ((CLASS_DATA (fsym
)->as
6513 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
6514 || CLASS_DATA (e
)->attr
.dimension
))
6515 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6516 fsym
->attr
.intent
!= INTENT_IN
6517 && (CLASS_DATA (fsym
)->attr
.class_pointer
6518 || CLASS_DATA (fsym
)->attr
.allocatable
),
6520 && e
->expr_type
== EXPR_VARIABLE
6521 && e
->symtree
->n
.sym
->attr
.optional
,
6522 CLASS_DATA (fsym
)->attr
.class_pointer
6523 || CLASS_DATA (fsym
)->attr
.allocatable
);
6525 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6526 allocated on entry, it must be deallocated. */
6527 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
6528 && (fsym
->attr
.allocatable
6529 || (fsym
->ts
.type
== BT_CLASS
6530 && CLASS_DATA (fsym
)->attr
.allocatable
))
6531 && !is_CFI_desc (fsym
, NULL
))
6536 gfc_init_block (&block
);
6538 if (e
->ts
.type
== BT_CLASS
)
6539 ptr
= gfc_class_data_get (ptr
);
6541 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
6544 gfc_add_expr_to_block (&block
, tmp
);
6545 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6546 void_type_node
, ptr
,
6548 gfc_add_expr_to_block (&block
, tmp
);
6550 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
6552 gfc_add_modify (&block
, ptr
,
6553 fold_convert (TREE_TYPE (ptr
),
6554 null_pointer_node
));
6555 gfc_add_expr_to_block (&block
, tmp
);
6557 else if (fsym
->ts
.type
== BT_CLASS
)
6560 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
6561 tmp
= gfc_get_symbol_decl (vtab
);
6562 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6563 ptr
= gfc_class_vptr_get (parmse
.expr
);
6564 gfc_add_modify (&block
, ptr
,
6565 fold_convert (TREE_TYPE (ptr
), tmp
));
6566 gfc_add_expr_to_block (&block
, tmp
);
6569 if (fsym
->attr
.optional
6570 && e
->expr_type
== EXPR_VARIABLE
6571 && e
->symtree
->n
.sym
->attr
.optional
)
6573 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6575 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6576 gfc_finish_block (&block
),
6577 build_empty_stmt (input_location
));
6580 tmp
= gfc_finish_block (&block
);
6582 gfc_add_expr_to_block (&se
->pre
, tmp
);
6585 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
6586 || fsym
->ts
.type
== BT_ASSUMED
)
6587 && e
->ts
.type
== BT_CLASS
6588 && !CLASS_DATA (e
)->attr
.dimension
6589 && !CLASS_DATA (e
)->attr
.codimension
)
6591 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
6592 /* The result is a class temporary, whose _data component
6593 must be freed to avoid a memory leak. */
6594 if (e
->expr_type
== EXPR_FUNCTION
6595 && CLASS_DATA (e
)->attr
.allocatable
)
6601 /* Borrow the function symbol to make a call to
6602 gfc_add_finalizer_call and then restore it. */
6603 tmp
= e
->symtree
->n
.sym
->backend_decl
;
6604 e
->symtree
->n
.sym
->backend_decl
6605 = TREE_OPERAND (parmse
.expr
, 0);
6606 e
->symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
6607 var
= gfc_lval_expr_from_sym (e
->symtree
->n
.sym
);
6608 finalized
= gfc_add_finalizer_call (&parmse
.post
,
6610 gfc_free_expr (var
);
6611 e
->symtree
->n
.sym
->backend_decl
= tmp
;
6612 e
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6614 /* Then free the class _data. */
6615 zero
= build_int_cst (TREE_TYPE (parmse
.expr
), 0);
6616 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6619 tmp
= build3_v (COND_EXPR
, tmp
,
6620 gfc_call_free (parmse
.expr
),
6621 build_empty_stmt (input_location
));
6622 gfc_add_expr_to_block (&parmse
.post
, tmp
);
6623 gfc_add_modify (&parmse
.post
, parmse
.expr
, zero
);
6627 /* Wrap scalar variable in a descriptor. We need to convert
6628 the address of a pointer back to the pointer itself before,
6629 we can assign it to the data field. */
6631 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
6632 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
6635 if (TREE_CODE (tmp
) == ADDR_EXPR
)
6636 tmp
= TREE_OPERAND (tmp
, 0);
6637 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
6639 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
6642 else if (fsym
&& e
->expr_type
!= EXPR_NULL
6643 && ((fsym
->attr
.pointer
6644 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
6645 || (fsym
->attr
.proc_pointer
6646 && !(e
->expr_type
== EXPR_VARIABLE
6647 && e
->symtree
->n
.sym
->attr
.dummy
))
6648 || (fsym
->attr
.proc_pointer
6649 && e
->expr_type
== EXPR_VARIABLE
6650 && gfc_is_proc_ptr_comp (e
))
6651 || (fsym
->attr
.allocatable
6652 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
6654 /* Scalar pointer dummy args require an extra level of
6655 indirection. The null pointer already contains
6656 this level of indirection. */
6657 parm_kind
= SCALAR_POINTER
;
6658 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
6662 else if (e
->ts
.type
== BT_CLASS
6663 && fsym
&& fsym
->ts
.type
== BT_CLASS
6664 && (CLASS_DATA (fsym
)->attr
.dimension
6665 || CLASS_DATA (fsym
)->attr
.codimension
))
6667 /* Pass a class array. */
6668 parmse
.use_offset
= 1;
6669 gfc_conv_expr_descriptor (&parmse
, e
);
6671 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6672 allocated on entry, it must be deallocated. */
6673 if (fsym
->attr
.intent
== INTENT_OUT
6674 && CLASS_DATA (fsym
)->attr
.allocatable
)
6679 gfc_init_block (&block
);
6681 ptr
= gfc_class_data_get (ptr
);
6683 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
6684 NULL_TREE
, NULL_TREE
,
6686 GFC_CAF_COARRAY_NOCOARRAY
);
6687 gfc_add_expr_to_block (&block
, tmp
);
6688 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6689 void_type_node
, ptr
,
6691 gfc_add_expr_to_block (&block
, tmp
);
6692 gfc_reset_vptr (&block
, e
);
6694 if (fsym
->attr
.optional
6695 && e
->expr_type
== EXPR_VARIABLE
6697 || (e
->ref
->type
== REF_ARRAY
6698 && e
->ref
->u
.ar
.type
!= AR_FULL
))
6699 && e
->symtree
->n
.sym
->attr
.optional
)
6701 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6703 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6704 gfc_finish_block (&block
),
6705 build_empty_stmt (input_location
));
6708 tmp
= gfc_finish_block (&block
);
6710 gfc_add_expr_to_block (&se
->pre
, tmp
);
6713 /* The conversion does not repackage the reference to a class
6714 array - _data descriptor. */
6715 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
6716 fsym
->attr
.intent
!= INTENT_IN
6717 && (CLASS_DATA (fsym
)->attr
.class_pointer
6718 || CLASS_DATA (fsym
)->attr
.allocatable
),
6720 && e
->expr_type
== EXPR_VARIABLE
6721 && e
->symtree
->n
.sym
->attr
.optional
,
6722 CLASS_DATA (fsym
)->attr
.class_pointer
6723 || CLASS_DATA (fsym
)->attr
.allocatable
);
6727 /* If the argument is a function call that may not create
6728 a temporary for the result, we have to check that we
6729 can do it, i.e. that there is no alias between this
6730 argument and another one. */
6731 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
6737 intent
= fsym
->attr
.intent
;
6739 intent
= INTENT_UNKNOWN
;
6741 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
6743 parmse
.force_tmp
= 1;
6745 iarg
= e
->value
.function
.actual
->expr
;
6747 /* Temporary needed if aliasing due to host association. */
6748 if (sym
->attr
.contained
6750 && !sym
->attr
.implicit_pure
6751 && !sym
->attr
.use_assoc
6752 && iarg
->expr_type
== EXPR_VARIABLE
6753 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
6754 parmse
.force_tmp
= 1;
6756 /* Ditto within module. */
6757 if (sym
->attr
.use_assoc
6759 && !sym
->attr
.implicit_pure
6760 && iarg
->expr_type
== EXPR_VARIABLE
6761 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
6762 parmse
.force_tmp
= 1;
6765 /* Special case for assumed-rank arrays: when passing an
6766 argument to a nonallocatable/nonpointer dummy, the bounds have
6767 to be reset as otherwise a last-dim ubound of -1 is
6768 indistinguishable from an assumed-size array in the callee. */
6769 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& fsym
->as
6770 && fsym
->as
->type
== AS_ASSUMED_RANK
6772 && e
->expr_type
== EXPR_VARIABLE
6773 && ((fsym
->ts
.type
== BT_CLASS
6774 && !CLASS_DATA (fsym
)->attr
.class_pointer
6775 && !CLASS_DATA (fsym
)->attr
.allocatable
)
6776 || (fsym
->ts
.type
!= BT_CLASS
6777 && !fsym
->attr
.pointer
&& !fsym
->attr
.allocatable
)))
6779 /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
6781 for (ref
= e
->ref
; ref
->next
; ref
= ref
->next
)
6783 if (ref
->u
.ar
.type
== AR_FULL
6784 && ref
->u
.ar
.as
->type
!= AS_ASSUMED_SIZE
)
6785 ref
->u
.ar
.type
= AR_SECTION
;
6788 if (sym
->attr
.is_bind_c
&& e
&& is_CFI_desc (fsym
, NULL
))
6789 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6790 gfc_conv_gfc_desc_to_cfi_desc (&parmse
, e
, fsym
);
6792 else if (e
->expr_type
== EXPR_VARIABLE
6793 && is_subref_array (e
)
6794 && !(fsym
&& fsym
->attr
.pointer
))
6795 /* The actual argument is a component reference to an
6796 array of derived types. In this case, the argument
6797 is converted to a temporary, which is passed and then
6798 written back after the procedure call. */
6799 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6800 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
6801 fsym
&& fsym
->attr
.pointer
);
6803 else if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->as
6804 && CLASS_DATA (e
)->as
->type
== AS_ASSUMED_SIZE
6805 && nodesc_arg
&& fsym
->ts
.type
== BT_DERIVED
)
6806 /* An assumed size class actual argument being passed to
6807 a 'no descriptor' formal argument just requires the
6808 data pointer to be passed. For class dummy arguments
6809 this is stored in the symbol backend decl.. */
6810 parmse
.expr
= e
->symtree
->n
.sym
->backend_decl
;
6812 else if (gfc_is_class_array_ref (e
, NULL
)
6813 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6814 /* The actual argument is a component reference to an
6815 array of derived types. In this case, the argument
6816 is converted to a temporary, which is passed and then
6817 written back after the procedure call.
6818 OOP-TODO: Insert code so that if the dynamic type is
6819 the same as the declared type, copy-in/copy-out does
6821 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6823 fsym
->attr
.pointer
);
6825 else if (gfc_is_class_array_function (e
)
6826 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
6827 /* See previous comment. For function actual argument,
6828 the write out is not needed so the intent is set as
6831 e
->must_finalize
= 1;
6832 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6833 INTENT_IN
, fsym
->attr
.pointer
);
6835 else if (fsym
&& fsym
->attr
.contiguous
6836 && !gfc_is_simply_contiguous (e
, false, true)
6837 && gfc_expr_is_variable (e
))
6839 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
6841 fsym
->attr
.pointer
);
6844 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
6847 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6848 allocated on entry, it must be deallocated.
6849 CFI descriptors are handled elsewhere. */
6850 if (fsym
&& fsym
->attr
.allocatable
6851 && fsym
->attr
.intent
== INTENT_OUT
6852 && !is_CFI_desc (fsym
, NULL
))
6854 if (fsym
->ts
.type
== BT_DERIVED
6855 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
6857 // deallocate the components first
6858 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
6859 parmse
.expr
, e
->rank
);
6860 /* But check whether dummy argument is optional. */
6861 if (tmp
!= NULL_TREE
6862 && fsym
->attr
.optional
6863 && e
->expr_type
== EXPR_VARIABLE
6864 && e
->symtree
->n
.sym
->attr
.optional
)
6867 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
6868 tmp
= build3_v (COND_EXPR
, present
, tmp
,
6869 build_empty_stmt (input_location
));
6871 if (tmp
!= NULL_TREE
)
6872 gfc_add_expr_to_block (&se
->pre
, tmp
);
6876 /* With bind(C), the actual argument is replaced by a bind-C
6877 descriptor; in this case, the data component arrives here,
6878 which shall not be dereferenced, but still freed and
6880 if (TREE_TYPE(tmp
) != pvoid_type_node
)
6881 tmp
= build_fold_indirect_ref_loc (input_location
,
6883 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
6884 tmp
= gfc_conv_descriptor_data_get (tmp
);
6885 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6886 NULL_TREE
, NULL_TREE
, true,
6888 GFC_CAF_COARRAY_NOCOARRAY
);
6889 if (fsym
->attr
.optional
6890 && e
->expr_type
== EXPR_VARIABLE
6891 && e
->symtree
->n
.sym
->attr
.optional
)
6892 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6894 gfc_conv_expr_present (e
->symtree
->n
.sym
),
6895 tmp
, build_empty_stmt (input_location
));
6896 gfc_add_expr_to_block (&se
->pre
, tmp
);
6900 /* Special case for an assumed-rank dummy argument. */
6901 if (!sym
->attr
.is_bind_c
&& e
&& fsym
&& e
->rank
> 0
6902 && (fsym
->ts
.type
== BT_CLASS
6903 ? (CLASS_DATA (fsym
)->as
6904 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
6905 : (fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
)))
6907 if (fsym
->ts
.type
== BT_CLASS
6908 ? (CLASS_DATA (fsym
)->attr
.class_pointer
6909 || CLASS_DATA (fsym
)->attr
.allocatable
)
6910 : (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
))
6912 /* Unallocated allocatable arrays and unassociated pointer
6913 arrays need their dtype setting if they are argument
6914 associated with assumed rank dummies to set the rank. */
6915 set_dtype_for_unallocated (&parmse
, e
);
6917 else if (e
->expr_type
== EXPR_VARIABLE
6918 && e
->symtree
->n
.sym
->attr
.dummy
6919 && (e
->ts
.type
== BT_CLASS
6920 ? (e
->ref
&& e
->ref
->next
6921 && e
->ref
->next
->type
== REF_ARRAY
6922 && e
->ref
->next
->u
.ar
.type
== AR_FULL
6923 && e
->ref
->next
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
6924 : (e
->ref
&& e
->ref
->type
== REF_ARRAY
6925 && e
->ref
->u
.ar
.type
== AR_FULL
6926 && e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)))
6928 /* Assumed-size actual to assumed-rank dummy requires
6929 dim[rank-1].ubound = -1. */
6931 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
6932 if (fsym
->ts
.type
== BT_CLASS
)
6933 tmp
= gfc_class_data_get (tmp
);
6934 minus_one
= build_int_cst (gfc_array_index_type
, -1);
6935 gfc_conv_descriptor_ubound_set (&parmse
.pre
, tmp
,
6936 gfc_rank_cst
[e
->rank
- 1],
6941 /* The case with fsym->attr.optional is that of a user subroutine
6942 with an interface indicating an optional argument. When we call
6943 an intrinsic subroutine, however, fsym is NULL, but we might still
6944 have an optional argument, so we proceed to the substitution
6946 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
6948 /* If an optional argument is itself an optional dummy argument,
6949 check its presence and substitute a null if absent. This is
6950 only needed when passing an array to an elemental procedure
6951 as then array elements are accessed - or no NULL pointer is
6952 allowed and a "1" or "0" should be passed if not present.
6953 When passing a non-array-descriptor full array to a
6954 non-array-descriptor dummy, no check is needed. For
6955 array-descriptor actual to array-descriptor dummy, see
6956 PR 41911 for why a check has to be inserted.
6957 fsym == NULL is checked as intrinsics required the descriptor
6958 but do not always set fsym.
6959 Also, it is necessary to pass a NULL pointer to library routines
6960 which usually ignore optional arguments, so they can handle
6961 these themselves. */
6962 if (e
->expr_type
== EXPR_VARIABLE
6963 && e
->symtree
->n
.sym
->attr
.optional
6964 && (((e
->rank
!= 0 && elemental_proc
)
6965 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
6969 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
6970 || fsym
->as
->type
== AS_ASSUMED_RANK
6971 || fsym
->as
->type
== AS_DEFERRED
)))))
6972 || se
->ignore_optional
))
6973 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
6974 e
->representation
.length
);
6979 /* Obtain the character length of an assumed character length
6980 length procedure from the typespec. */
6981 if (fsym
->ts
.type
== BT_CHARACTER
6982 && parmse
.string_length
== NULL_TREE
6983 && e
->ts
.type
== BT_PROCEDURE
6984 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
6985 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
6986 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6988 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
6989 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
6993 if (fsym
&& need_interface_mapping
&& e
)
6994 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
6996 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
6997 gfc_add_block_to_block (&post
, &parmse
.post
);
6999 /* Allocated allocatable components of derived types must be
7000 deallocated for non-variable scalars, array arguments to elemental
7001 procedures, and array arguments with descriptor to non-elemental
7002 procedures. As bounds information for descriptorless arrays is no
7003 longer available here, they are dealt with in trans-array.c
7004 (gfc_conv_array_parameter). */
7005 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
7006 && e
->ts
.u
.derived
->attr
.alloc_comp
7007 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
7008 && !expr_may_alias_variables (e
, elemental_proc
))
7011 /* It is known the e returns a structure type with at least one
7012 allocatable component. When e is a function, ensure that the
7013 function is called once only by using a temporary variable. */
7014 if (!DECL_P (parmse
.expr
))
7015 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
7016 parmse
.expr
, &se
->pre
);
7018 if (fsym
&& fsym
->attr
.value
)
7021 tmp
= build_fold_indirect_ref_loc (input_location
,
7024 parm_rank
= e
->rank
;
7032 case (SCALAR_POINTER
):
7033 tmp
= build_fold_indirect_ref_loc (input_location
,
7038 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
7040 /* The derived type is passed to gfc_deallocate_alloc_comp.
7041 Therefore, class actuals can be handled correctly but derived
7042 types passed to class formals need the _data component. */
7043 tmp
= gfc_class_data_get (tmp
);
7044 if (!CLASS_DATA (fsym
)->attr
.dimension
)
7045 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7048 if (e
->expr_type
== EXPR_OP
7049 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
7050 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
7053 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
7054 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
7056 gfc_add_expr_to_block (&se
->post
, local_tmp
);
7059 if (!finalized
&& !e
->must_finalize
)
7061 bool scalar_res_outside_loop
;
7062 scalar_res_outside_loop
= e
->expr_type
== EXPR_FUNCTION
7066 /* Scalars passed to an assumed rank argument are converted to
7067 a descriptor. Obtain the data field before deallocating any
7068 allocatable components. */
7069 if (parm_rank
== 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
7070 tmp
= gfc_conv_descriptor_data_get (tmp
);
7072 if (scalar_res_outside_loop
)
7074 /* Go through the ss chain to find the argument and use
7075 the stored value. */
7076 gfc_ss
*tmp_ss
= parmse
.loop
->ss
;
7077 for (; tmp_ss
; tmp_ss
= tmp_ss
->next
)
7079 && tmp_ss
->info
->expr
== e
7080 && tmp_ss
->info
->data
.scalar
.value
!= NULL_TREE
)
7082 tmp
= tmp_ss
->info
->data
.scalar
.value
;
7089 if (derived_array
!= NULL_TREE
)
7090 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
,
7093 else if ((e
->ts
.type
== BT_CLASS
7094 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
7095 || e
->ts
.type
== BT_DERIVED
)
7096 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
,
7098 else if (e
->ts
.type
== BT_CLASS
)
7099 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (e
)->ts
.u
.derived
,
7102 if (scalar_res_outside_loop
)
7103 gfc_add_expr_to_block (&parmse
.loop
->post
, tmp
);
7105 gfc_prepend_expr_to_block (&post
, tmp
);
7109 /* Add argument checking of passing an unallocated/NULL actual to
7110 a nonallocatable/nonpointer dummy. */
7112 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
7114 symbol_attribute attr
;
7118 symbol_attribute fsym_attr
;
7122 if (fsym
->ts
.type
== BT_CLASS
)
7124 fsym_attr
= CLASS_DATA (fsym
)->attr
;
7125 fsym_attr
.pointer
= fsym_attr
.class_pointer
;
7128 fsym_attr
= fsym
->attr
;
7131 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
7132 attr
= gfc_expr_attr (e
);
7134 goto end_pointer_check
;
7136 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
7137 allocatable to an optional dummy, cf. 12.5.2.12. */
7138 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
7139 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
7140 goto end_pointer_check
;
7144 /* If the actual argument is an optional pointer/allocatable and
7145 the formal argument takes an nonpointer optional value,
7146 it is invalid to pass a non-present argument on, even
7147 though there is no technical reason for this in gfortran.
7148 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
7149 tree present
, null_ptr
, type
;
7151 if (attr
.allocatable
7152 && (fsym
== NULL
|| !fsym_attr
.allocatable
))
7153 msg
= xasprintf ("Allocatable actual argument '%s' is not "
7154 "allocated or not present",
7155 e
->symtree
->n
.sym
->name
);
7156 else if (attr
.pointer
7157 && (fsym
== NULL
|| !fsym_attr
.pointer
))
7158 msg
= xasprintf ("Pointer actual argument '%s' is not "
7159 "associated or not present",
7160 e
->symtree
->n
.sym
->name
);
7161 else if (attr
.proc_pointer
&& !e
->value
.function
.actual
7162 && (fsym
== NULL
|| !fsym_attr
.proc_pointer
))
7163 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
7164 "associated or not present",
7165 e
->symtree
->n
.sym
->name
);
7167 goto end_pointer_check
;
7169 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
7170 type
= TREE_TYPE (present
);
7171 present
= fold_build2_loc (input_location
, EQ_EXPR
,
7172 logical_type_node
, present
,
7174 null_pointer_node
));
7175 type
= TREE_TYPE (parmse
.expr
);
7176 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
7177 logical_type_node
, parmse
.expr
,
7179 null_pointer_node
));
7180 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
7181 logical_type_node
, present
, null_ptr
);
7185 if (attr
.allocatable
7186 && (fsym
== NULL
|| !fsym_attr
.allocatable
))
7187 msg
= xasprintf ("Allocatable actual argument '%s' is not "
7188 "allocated", e
->symtree
->n
.sym
->name
);
7189 else if (attr
.pointer
7190 && (fsym
== NULL
|| !fsym_attr
.pointer
))
7191 msg
= xasprintf ("Pointer actual argument '%s' is not "
7192 "associated", e
->symtree
->n
.sym
->name
);
7193 else if (attr
.proc_pointer
&& !e
->value
.function
.actual
7194 && (fsym
== NULL
|| !fsym_attr
.proc_pointer
))
7195 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
7196 "associated", e
->symtree
->n
.sym
->name
);
7198 goto end_pointer_check
;
7200 if (fsym
&& fsym
->ts
.type
== BT_CLASS
)
7202 tmp
= build_fold_indirect_ref_loc (input_location
,
7204 tmp
= gfc_class_data_get (tmp
);
7205 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
7206 tmp
= gfc_conv_descriptor_data_get (tmp
);
7211 /* If the argument is passed by value, we need to strip the
7213 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
7214 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7216 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7217 logical_type_node
, tmp
,
7218 fold_convert (TREE_TYPE (tmp
),
7219 null_pointer_node
));
7222 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
7228 /* Deferred length dummies pass the character length by reference
7229 so that the value can be returned. */
7230 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
7232 if (INDIRECT_REF_P (parmse
.string_length
))
7233 /* In chains of functions/procedure calls the string_length already
7234 is a pointer to the variable holding the length. Therefore
7235 remove the deref on call. */
7236 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
7239 tmp
= parmse
.string_length
;
7240 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
7241 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
7242 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7246 /* Character strings are passed as two parameters, a length and a
7247 pointer - except for Bind(c) which only passes the pointer.
7248 An unlimited polymorphic formal argument likewise does not
7250 if (parmse
.string_length
!= NULL_TREE
7251 && !sym
->attr
.is_bind_c
7252 && !(fsym
&& UNLIMITED_POLY (fsym
)))
7253 vec_safe_push (stringargs
, parmse
.string_length
);
7255 /* When calling __copy for character expressions to unlimited
7256 polymorphic entities, the dst argument needs a string length. */
7257 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
7258 && startswith (sym
->name
, "__vtab_CHARACTER")
7259 && arg
->next
&& arg
->next
->expr
7260 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
7261 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
7262 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
7263 vec_safe_push (stringargs
, parmse
.string_length
);
7265 /* For descriptorless coarrays and assumed-shape coarray dummies, we
7266 pass the token and the offset as additional arguments. */
7267 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
7268 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
7269 && !fsym
->attr
.allocatable
)
7270 || (fsym
->ts
.type
== BT_CLASS
7271 && CLASS_DATA (fsym
)->attr
.codimension
7272 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
7274 /* Token and offset. */
7275 vec_safe_push (stringargs
, null_pointer_node
);
7276 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
7277 gcc_assert (fsym
->attr
.optional
);
7279 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
7280 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
7281 && !fsym
->attr
.allocatable
)
7282 || (fsym
->ts
.type
== BT_CLASS
7283 && CLASS_DATA (fsym
)->attr
.codimension
7284 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
7286 tree caf_decl
, caf_type
;
7289 caf_decl
= gfc_get_tree_for_caf_expr (e
);
7290 caf_type
= TREE_TYPE (caf_decl
);
7292 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
7293 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
7294 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
7295 tmp
= gfc_conv_descriptor_token (caf_decl
);
7296 else if (DECL_LANG_SPECIFIC (caf_decl
)
7297 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
7298 tmp
= GFC_DECL_TOKEN (caf_decl
);
7301 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
7302 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
7303 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
7306 vec_safe_push (stringargs
, tmp
);
7308 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
7309 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
7310 offset
= build_int_cst (gfc_array_index_type
, 0);
7311 else if (DECL_LANG_SPECIFIC (caf_decl
)
7312 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
7313 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
7314 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
7315 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
7317 offset
= build_int_cst (gfc_array_index_type
, 0);
7319 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
7320 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
7323 gcc_assert (POINTER_TYPE_P (caf_type
));
7327 tmp2
= fsym
->ts
.type
== BT_CLASS
7328 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
7329 if ((fsym
->ts
.type
!= BT_CLASS
7330 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
7331 || fsym
->as
->type
== AS_ASSUMED_RANK
))
7332 || (fsym
->ts
.type
== BT_CLASS
7333 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
7334 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
7336 if (fsym
->ts
.type
== BT_CLASS
)
7337 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7340 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7341 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
7343 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
7344 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7346 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
7347 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
7350 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
7353 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7354 gfc_array_index_type
,
7355 fold_convert (gfc_array_index_type
, tmp2
),
7356 fold_convert (gfc_array_index_type
, tmp
));
7357 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
7358 gfc_array_index_type
, offset
, tmp
);
7360 vec_safe_push (stringargs
, offset
);
7363 vec_safe_push (arglist
, parmse
.expr
);
7365 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
7369 else if (sym
->ts
.type
== BT_CLASS
)
7370 ts
= CLASS_DATA (sym
)->ts
;
7374 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
7375 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
7376 else if (ts
.type
== BT_CHARACTER
)
7378 if (ts
.u
.cl
->length
== NULL
)
7380 /* Assumed character length results are not allowed by C418 of the 2003
7381 standard and are trapped in resolve.c; except in the case of SPREAD
7382 (and other intrinsics?) and dummy functions. In the case of SPREAD,
7383 we take the character length of the first argument for the result.
7384 For dummies, we have to look through the formal argument list for
7385 this function and use the character length found there.*/
7387 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
7388 else if (!sym
->attr
.dummy
)
7389 cl
.backend_decl
= (*stringargs
)[0];
7392 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
7393 for (; formal
; formal
= formal
->next
)
7394 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
7395 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
7397 len
= cl
.backend_decl
;
7403 /* Calculate the length of the returned string. */
7404 gfc_init_se (&parmse
, NULL
);
7405 if (need_interface_mapping
)
7406 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
7408 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
7409 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
7410 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
7412 /* TODO: It would be better to have the charlens as
7413 gfc_charlen_type_node already when the interface is
7414 created instead of converting it here (see PR 84615). */
7415 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
7416 gfc_charlen_type_node
,
7417 fold_convert (gfc_charlen_type_node
, tmp
),
7418 build_zero_cst (gfc_charlen_type_node
));
7419 cl
.backend_decl
= tmp
;
7422 /* Set up a charlen structure for it. */
7427 len
= cl
.backend_decl
;
7430 byref
= (comp
&& (comp
->attr
.dimension
7431 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
7432 || (!comp
&& gfc_return_by_reference (sym
));
7435 if (se
->direct_byref
)
7437 /* Sometimes, too much indirection can be applied; e.g. for
7438 function_result = array_valued_recursive_function. */
7439 if (TREE_TYPE (TREE_TYPE (se
->expr
))
7440 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
7441 && GFC_DESCRIPTOR_TYPE_P
7442 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
7443 se
->expr
= build_fold_indirect_ref_loc (input_location
,
7446 /* If the lhs of an assignment x = f(..) is allocatable and
7447 f2003 is allowed, we must do the automatic reallocation.
7448 TODO - deal with intrinsics, without using a temporary. */
7449 if (flag_realloc_lhs
7450 && se
->ss
&& se
->ss
->loop_chain
7451 && se
->ss
->loop_chain
->is_alloc_lhs
7452 && !expr
->value
.function
.isym
7453 && sym
->result
->as
!= NULL
)
7455 /* Evaluate the bounds of the result, if known. */
7456 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
7459 /* Perform the automatic reallocation. */
7460 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
7462 gfc_add_expr_to_block (&se
->pre
, tmp
);
7464 /* Pass the temporary as the first argument. */
7465 result
= info
->descriptor
;
7468 result
= build_fold_indirect_ref_loc (input_location
,
7470 vec_safe_push (retargs
, se
->expr
);
7472 else if (comp
&& comp
->attr
.dimension
)
7474 gcc_assert (se
->loop
&& info
);
7476 /* Set the type of the array. */
7477 tmp
= gfc_typenode_for_spec (&comp
->ts
);
7478 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
7480 /* Evaluate the bounds of the result, if known. */
7481 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
7483 /* If the lhs of an assignment x = f(..) is allocatable and
7484 f2003 is allowed, we must not generate the function call
7485 here but should just send back the results of the mapping.
7486 This is signalled by the function ss being flagged. */
7487 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
7489 gfc_free_interface_mapping (&mapping
);
7490 return has_alternate_specifier
;
7493 /* Create a temporary to store the result. In case the function
7494 returns a pointer, the temporary will be a shallow copy and
7495 mustn't be deallocated. */
7496 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
7497 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
7498 tmp
, NULL_TREE
, false,
7499 !comp
->attr
.pointer
, callee_alloc
,
7500 &se
->ss
->info
->expr
->where
);
7502 /* Pass the temporary as the first argument. */
7503 result
= info
->descriptor
;
7504 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7505 vec_safe_push (retargs
, tmp
);
7507 else if (!comp
&& sym
->result
->attr
.dimension
)
7509 gcc_assert (se
->loop
&& info
);
7511 /* Set the type of the array. */
7512 tmp
= gfc_typenode_for_spec (&ts
);
7513 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
7515 /* Evaluate the bounds of the result, if known. */
7516 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
7518 /* If the lhs of an assignment x = f(..) is allocatable and
7519 f2003 is allowed, we must not generate the function call
7520 here but should just send back the results of the mapping.
7521 This is signalled by the function ss being flagged. */
7522 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
7524 gfc_free_interface_mapping (&mapping
);
7525 return has_alternate_specifier
;
7528 /* Create a temporary to store the result. In case the function
7529 returns a pointer, the temporary will be a shallow copy and
7530 mustn't be deallocated. */
7531 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
7532 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
7533 tmp
, NULL_TREE
, false,
7534 !sym
->attr
.pointer
, callee_alloc
,
7535 &se
->ss
->info
->expr
->where
);
7537 /* Pass the temporary as the first argument. */
7538 result
= info
->descriptor
;
7539 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
7540 vec_safe_push (retargs
, tmp
);
7542 else if (ts
.type
== BT_CHARACTER
)
7544 /* Pass the string length. */
7545 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
7546 type
= build_pointer_type (type
);
7548 /* Emit a DECL_EXPR for the VLA type. */
7549 tmp
= TREE_TYPE (type
);
7551 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
7553 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
7554 DECL_ARTIFICIAL (tmp
) = 1;
7555 DECL_IGNORED_P (tmp
) = 1;
7556 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
7557 TREE_TYPE (tmp
), tmp
);
7558 gfc_add_expr_to_block (&se
->pre
, tmp
);
7561 /* Return an address to a char[0:len-1]* temporary for
7562 character pointers. */
7563 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7564 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7566 var
= gfc_create_var (type
, "pstr");
7568 if ((!comp
&& sym
->attr
.allocatable
)
7569 || (comp
&& comp
->attr
.allocatable
))
7571 gfc_add_modify (&se
->pre
, var
,
7572 fold_convert (TREE_TYPE (var
),
7573 null_pointer_node
));
7574 tmp
= gfc_call_free (var
);
7575 gfc_add_expr_to_block (&se
->post
, tmp
);
7578 /* Provide an address expression for the function arguments. */
7579 var
= gfc_build_addr_expr (NULL_TREE
, var
);
7582 var
= gfc_conv_string_tmp (se
, type
, len
);
7584 vec_safe_push (retargs
, var
);
7588 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
7590 type
= gfc_get_complex_type (ts
.kind
);
7591 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
7592 vec_safe_push (retargs
, var
);
7595 /* Add the string length to the argument list. */
7596 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
7600 tmp
= gfc_evaluate_now (len
, &se
->pre
);
7601 TREE_STATIC (tmp
) = 1;
7602 gfc_add_modify (&se
->pre
, tmp
,
7603 build_int_cst (TREE_TYPE (tmp
), 0));
7604 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
7605 vec_safe_push (retargs
, tmp
);
7607 else if (ts
.type
== BT_CHARACTER
)
7608 vec_safe_push (retargs
, len
);
7610 gfc_free_interface_mapping (&mapping
);
7612 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7613 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
7614 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
7615 vec_safe_reserve (retargs
, arglen
);
7617 /* Add the return arguments. */
7618 vec_safe_splice (retargs
, arglist
);
7620 /* Add the hidden present status for optional+value to the arguments. */
7621 vec_safe_splice (retargs
, optionalargs
);
7623 /* Add the hidden string length parameters to the arguments. */
7624 vec_safe_splice (retargs
, stringargs
);
7626 /* We may want to append extra arguments here. This is used e.g. for
7627 calls to libgfortran_matmul_??, which need extra information. */
7628 vec_safe_splice (retargs
, append_args
);
7632 /* Generate the actual call. */
7633 if (base_object
== NULL_TREE
)
7634 conv_function_val (se
, sym
, expr
, args
);
7636 conv_base_obj_fcn_val (se
, base_object
, expr
);
7638 /* If there are alternate return labels, function type should be
7639 integer. Can't modify the type in place though, since it can be shared
7640 with other functions. For dummy arguments, the typing is done to
7641 this result, even if it has to be repeated for each call. */
7642 if (has_alternate_specifier
7643 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
7645 if (!sym
->attr
.dummy
)
7647 TREE_TYPE (sym
->backend_decl
)
7648 = build_function_type (integer_type_node
,
7649 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
7650 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
7653 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
7656 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
7657 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
7659 /* Allocatable scalar function results must be freed and nullified
7660 after use. This necessitates the creation of a temporary to
7661 hold the result to prevent duplicate calls. */
7662 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
7663 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
7664 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
7666 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7667 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
7669 tmp
= gfc_call_free (tmp
);
7670 gfc_add_expr_to_block (&post
, tmp
);
7671 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
7674 /* If we have a pointer function, but we don't want a pointer, e.g.
7677 where f is pointer valued, we have to dereference the result. */
7678 if (!se
->want_pointer
&& !byref
7679 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7680 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
7681 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7683 /* f2c calling conventions require a scalar default real function to
7684 return a double precision result. Convert this back to default
7685 real. We only care about the cases that can happen in Fortran 77.
7687 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
7688 && sym
->ts
.kind
== gfc_default_real_kind
7689 && !sym
->attr
.always_explicit
)
7690 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
7692 /* A pure function may still have side-effects - it may modify its
7694 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7696 if (!sym
->attr
.pure
)
7697 TREE_SIDE_EFFECTS (se
->expr
) = 1;
7702 /* Add the function call to the pre chain. There is no expression. */
7703 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
7704 se
->expr
= NULL_TREE
;
7706 if (!se
->direct_byref
)
7708 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
7710 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
7712 /* Check the data pointer hasn't been modified. This would
7713 happen in a function returning a pointer. */
7714 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
7715 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7718 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
7721 se
->expr
= info
->descriptor
;
7722 /* Bundle in the string length. */
7723 se
->string_length
= len
;
7725 else if (ts
.type
== BT_CHARACTER
)
7727 /* Dereference for character pointer results. */
7728 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
7729 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
7730 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7734 se
->string_length
= len
;
7738 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
7739 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
7744 /* Associate the rhs class object's meta-data with the result, when the
7745 result is a temporary. */
7746 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
7747 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
7748 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
7751 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
7753 gfc_init_se (&parmse
, NULL
);
7754 parmse
.data_not_needed
= 1;
7755 gfc_conv_expr (&parmse
, class_expr
);
7756 if (!DECL_LANG_SPECIFIC (result
))
7757 gfc_allocate_lang_decl (result
);
7758 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
7759 gfc_free_expr (class_expr
);
7760 /* -fcheck= can add diagnostic code, which has to be placed before
7762 if (parmse
.pre
.head
!= NULL
)
7763 gfc_add_expr_to_block (&se
->pre
, parmse
.pre
.head
);
7764 gcc_assert (parmse
.post
.head
== NULL_TREE
);
7767 /* Follow the function call with the argument post block. */
7770 gfc_add_block_to_block (&se
->pre
, &post
);
7772 /* Transformational functions of derived types with allocatable
7773 components must have the result allocatable components copied when the
7774 argument is actually given. */
7775 arg
= expr
->value
.function
.actual
;
7776 if (result
&& arg
&& expr
->rank
7777 && expr
->value
.function
.isym
7778 && expr
->value
.function
.isym
->transformational
7780 && arg
->expr
->ts
.type
== BT_DERIVED
7781 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
7784 /* Copy the allocatable components. We have to use a
7785 temporary here to prevent source allocatable components
7786 from being corrupted. */
7787 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
7788 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
7789 result
, tmp2
, expr
->rank
, 0);
7790 gfc_add_expr_to_block (&se
->pre
, tmp
);
7791 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
7793 gfc_add_expr_to_block (&se
->pre
, tmp
);
7795 /* Finally free the temporary's data field. */
7796 tmp
= gfc_conv_descriptor_data_get (tmp2
);
7797 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
7798 NULL_TREE
, NULL_TREE
, true,
7799 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
7800 gfc_add_expr_to_block (&se
->pre
, tmp
);
7805 /* For a function with a class array result, save the result as
7806 a temporary, set the info fields needed by the scalarizer and
7807 call the finalization function of the temporary. Note that the
7808 nullification of allocatable components needed by the result
7809 is done in gfc_trans_assignment_1. */
7810 if (expr
&& ((gfc_is_class_array_function (expr
)
7811 && se
->ss
&& se
->ss
->loop
)
7812 || gfc_is_alloc_class_scalar_function (expr
))
7813 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
7814 && expr
->must_finalize
)
7819 if (se
->ss
&& se
->ss
->loop
)
7821 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
7822 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
7823 tmp
= gfc_class_data_get (se
->expr
);
7824 info
->descriptor
= tmp
;
7825 info
->data
= gfc_conv_descriptor_data_get (tmp
);
7826 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
7827 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
7829 tree dim
= gfc_rank_cst
[n
];
7830 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
7831 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
7836 /* TODO Eliminate the doubling of temporaries. This
7837 one is necessary to ensure no memory leakage. */
7838 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
7839 tmp
= gfc_class_data_get (se
->expr
);
7840 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
7841 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
7844 if ((gfc_is_class_array_function (expr
)
7845 || gfc_is_alloc_class_scalar_function (expr
))
7846 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
7847 goto no_finalization
;
7849 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
7850 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
7853 fold_convert (TREE_TYPE (final_fndecl
),
7854 null_pointer_node
));
7855 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
7857 tmp
= build_call_expr_loc (input_location
,
7859 gfc_build_addr_expr (NULL
, tmp
),
7860 gfc_class_vtab_size_get (se
->expr
),
7861 boolean_false_node
);
7862 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7863 void_type_node
, is_final
, tmp
,
7864 build_empty_stmt (input_location
));
7866 if (se
->ss
&& se
->ss
->loop
)
7868 gfc_prepend_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7869 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7872 fold_convert (TREE_TYPE (info
->data
),
7873 null_pointer_node
));
7874 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7875 void_type_node
, tmp
,
7876 gfc_call_free (info
->data
),
7877 build_empty_stmt (input_location
));
7878 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
7883 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7884 classdata
= gfc_class_data_get (se
->expr
);
7885 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7888 fold_convert (TREE_TYPE (classdata
),
7889 null_pointer_node
));
7890 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
7891 void_type_node
, tmp
,
7892 gfc_call_free (classdata
),
7893 build_empty_stmt (input_location
));
7894 gfc_add_expr_to_block (&se
->post
, tmp
);
7899 gfc_add_block_to_block (&se
->post
, &post
);
7902 return has_alternate_specifier
;
7906 /* Fill a character string with spaces. */
7909 fill_with_spaces (tree start
, tree type
, tree size
)
7911 stmtblock_t block
, loop
;
7912 tree i
, el
, exit_label
, cond
, tmp
;
7914 /* For a simple char type, we can call memset(). */
7915 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
7916 return build_call_expr_loc (input_location
,
7917 builtin_decl_explicit (BUILT_IN_MEMSET
),
7919 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
7920 lang_hooks
.to_target_charset (' ')),
7921 fold_convert (size_type_node
, size
));
7923 /* Otherwise, we use a loop:
7924 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7928 /* Initialize variables. */
7929 gfc_init_block (&block
);
7930 i
= gfc_create_var (sizetype
, "i");
7931 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
7932 el
= gfc_create_var (build_pointer_type (type
), "el");
7933 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
7934 exit_label
= gfc_build_label_decl (NULL_TREE
);
7935 TREE_USED (exit_label
) = 1;
7939 gfc_init_block (&loop
);
7941 /* Exit condition. */
7942 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
7943 build_zero_cst (sizetype
));
7944 tmp
= build1_v (GOTO_EXPR
, exit_label
);
7945 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
7946 build_empty_stmt (input_location
));
7947 gfc_add_expr_to_block (&loop
, tmp
);
7950 gfc_add_modify (&loop
,
7951 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
7952 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
7954 /* Increment loop variables. */
7955 gfc_add_modify (&loop
, i
,
7956 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
7957 TYPE_SIZE_UNIT (type
)));
7958 gfc_add_modify (&loop
, el
,
7959 fold_build_pointer_plus_loc (input_location
,
7960 el
, TYPE_SIZE_UNIT (type
)));
7962 /* Making the loop... actually loop! */
7963 tmp
= gfc_finish_block (&loop
);
7964 tmp
= build1_v (LOOP_EXPR
, tmp
);
7965 gfc_add_expr_to_block (&block
, tmp
);
7967 /* The exit label. */
7968 tmp
= build1_v (LABEL_EXPR
, exit_label
);
7969 gfc_add_expr_to_block (&block
, tmp
);
7972 return gfc_finish_block (&block
);
7976 /* Generate code to copy a string. */
7979 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
7980 int dkind
, tree slength
, tree src
, int skind
)
7982 tree tmp
, dlen
, slen
;
7991 stmtblock_t tempblock
;
7993 gcc_assert (dkind
== skind
);
7995 if (slength
!= NULL_TREE
)
7997 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
7998 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
8002 slen
= build_one_cst (gfc_charlen_type_node
);
8006 if (dlength
!= NULL_TREE
)
8008 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
8009 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
8013 dlen
= build_one_cst (gfc_charlen_type_node
);
8017 /* Assign directly if the types are compatible. */
8018 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
8019 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
8021 gfc_add_modify (block
, dsc
, ssc
);
8025 /* The string copy algorithm below generates code like
8029 if (srclen < destlen)
8031 memmove (dest, src, srclen);
8033 memset (&dest[srclen], ' ', destlen - srclen);
8037 // Truncate if too long.
8038 memmove (dest, src, destlen);
8043 /* Do nothing if the destination length is zero. */
8044 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
8045 build_zero_cst (TREE_TYPE (dlen
)));
8047 /* For non-default character kinds, we have to multiply the string
8048 length by the base type size. */
8049 chartype
= gfc_get_char_type (dkind
);
8050 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
8052 fold_convert (TREE_TYPE (slen
),
8053 TYPE_SIZE_UNIT (chartype
)));
8054 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
8056 fold_convert (TREE_TYPE (dlen
),
8057 TYPE_SIZE_UNIT (chartype
)));
8059 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
8060 dest
= fold_convert (pvoid_type_node
, dest
);
8062 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
8064 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
8065 src
= fold_convert (pvoid_type_node
, src
);
8067 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8069 /* Truncate string if source is too long. */
8070 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
8073 /* Copy and pad with spaces. */
8074 tmp3
= build_call_expr_loc (input_location
,
8075 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8077 fold_convert (size_type_node
, slen
));
8079 /* Wstringop-overflow appears at -O3 even though this warning is not
8080 explicitly available in fortran nor can it be switched off. If the
8081 source length is a constant, its negative appears as a very large
8082 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
8083 the result of the MINUS_EXPR suppresses this spurious warning. */
8084 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8085 TREE_TYPE(dlen
), dlen
, slen
);
8086 if (slength
&& TREE_CONSTANT (slength
))
8087 tmp
= gfc_evaluate_now (tmp
, block
);
8089 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
8090 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
8092 gfc_init_block (&tempblock
);
8093 gfc_add_expr_to_block (&tempblock
, tmp3
);
8094 gfc_add_expr_to_block (&tempblock
, tmp4
);
8095 tmp3
= gfc_finish_block (&tempblock
);
8097 /* The truncated memmove if the slen >= dlen. */
8098 tmp2
= build_call_expr_loc (input_location
,
8099 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
8101 fold_convert (size_type_node
, dlen
));
8103 /* The whole copy_string function is there. */
8104 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
8106 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
8107 build_empty_stmt (input_location
));
8108 gfc_add_expr_to_block (block
, tmp
);
8112 /* Translate a statement function.
8113 The value of a statement function reference is obtained by evaluating the
8114 expression using the values of the actual arguments for the values of the
8115 corresponding dummy arguments. */
8118 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
8122 gfc_formal_arglist
*fargs
;
8123 gfc_actual_arglist
*args
;
8126 gfc_saved_var
*saved_vars
;
8132 sym
= expr
->symtree
->n
.sym
;
8133 args
= expr
->value
.function
.actual
;
8134 gfc_init_se (&lse
, NULL
);
8135 gfc_init_se (&rse
, NULL
);
8138 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
8140 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
8141 temp_vars
= XCNEWVEC (tree
, n
);
8143 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8144 fargs
= fargs
->next
, n
++)
8146 /* Each dummy shall be specified, explicitly or implicitly, to be
8148 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
8151 if (fsym
->ts
.type
== BT_CHARACTER
)
8153 /* Copy string arguments. */
8156 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
8157 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
8159 /* Create a temporary to hold the value. */
8160 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
8161 fsym
->ts
.u
.cl
->backend_decl
8162 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
8164 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
8165 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
8167 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
8169 gfc_conv_expr (&rse
, args
->expr
);
8170 gfc_conv_string_parameter (&rse
);
8171 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
8172 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
8174 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
8175 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
8176 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
8177 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
8181 /* For everything else, just evaluate the expression. */
8183 /* Create a temporary to hold the value. */
8184 type
= gfc_typenode_for_spec (&fsym
->ts
);
8185 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
8187 gfc_conv_expr (&lse
, args
->expr
);
8189 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
8190 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
8191 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
8197 /* Use the temporary variables in place of the real ones. */
8198 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8199 fargs
= fargs
->next
, n
++)
8200 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
8202 gfc_conv_expr (se
, sym
->value
);
8204 if (sym
->ts
.type
== BT_CHARACTER
)
8206 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
8208 /* Force the expression to the correct length. */
8209 if (!INTEGER_CST_P (se
->string_length
)
8210 || tree_int_cst_lt (se
->string_length
,
8211 sym
->ts
.u
.cl
->backend_decl
))
8213 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
8214 tmp
= gfc_create_var (type
, sym
->name
);
8215 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
8216 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
8217 sym
->ts
.kind
, se
->string_length
, se
->expr
,
8221 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
8224 /* Restore the original variables. */
8225 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
8226 fargs
= fargs
->next
, n
++)
8227 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
8233 /* Translate a function expression. */
8236 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
8240 if (expr
->value
.function
.isym
)
8242 gfc_conv_intrinsic_function (se
, expr
);
8246 /* expr.value.function.esym is the resolved (specific) function symbol for
8247 most functions. However this isn't set for dummy procedures. */
8248 sym
= expr
->value
.function
.esym
;
8250 sym
= expr
->symtree
->n
.sym
;
8252 /* The IEEE_ARITHMETIC functions are caught here. */
8253 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
8254 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
8257 /* We distinguish statement functions from general functions to improve
8258 runtime performance. */
8259 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
8261 gfc_conv_statement_function (se
, expr
);
8265 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
8270 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
8273 is_zero_initializer_p (gfc_expr
* expr
)
8275 if (expr
->expr_type
!= EXPR_CONSTANT
)
8278 /* We ignore constants with prescribed memory representations for now. */
8279 if (expr
->representation
.string
)
8282 switch (expr
->ts
.type
)
8285 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
8288 return mpfr_zero_p (expr
->value
.real
)
8289 && MPFR_SIGN (expr
->value
.real
) >= 0;
8292 return expr
->value
.logical
== 0;
8295 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
8296 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
8297 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
8298 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
8308 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
8313 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
8314 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
8316 gfc_conv_tmp_array_ref (se
);
8320 /* Build a static initializer. EXPR is the expression for the initial value.
8321 The other parameters describe the variable of the component being
8322 initialized. EXPR may be null. */
8325 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
8326 bool array
, bool pointer
, bool procptr
)
8330 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
8331 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
8332 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
8333 return build_constructor (type
, NULL
);
8335 if (!(expr
|| pointer
|| procptr
))
8338 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
8339 (these are the only two iso_c_binding derived types that can be
8340 used as initialization expressions). If so, we need to modify
8341 the 'expr' to be that for a (void *). */
8342 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
8343 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
8345 if (TREE_CODE (type
) == ARRAY_TYPE
)
8346 return build_constructor (type
, NULL
);
8347 else if (POINTER_TYPE_P (type
))
8348 return build_int_cst (type
, 0);
8353 if (array
&& !procptr
)
8356 /* Arrays need special handling. */
8358 ctor
= gfc_build_null_descriptor (type
);
8359 /* Special case assigning an array to zero. */
8360 else if (is_zero_initializer_p (expr
))
8361 ctor
= build_constructor (type
, NULL
);
8363 ctor
= gfc_conv_array_initializer (type
, expr
);
8364 TREE_STATIC (ctor
) = 1;
8367 else if (pointer
|| procptr
)
8369 if (ts
->type
== BT_CLASS
&& !procptr
)
8371 gfc_init_se (&se
, NULL
);
8372 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
8373 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
8374 TREE_STATIC (se
.expr
) = 1;
8377 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
8378 return fold_convert (type
, null_pointer_node
);
8381 gfc_init_se (&se
, NULL
);
8382 se
.want_pointer
= 1;
8383 gfc_conv_expr (&se
, expr
);
8384 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
8394 gfc_init_se (&se
, NULL
);
8395 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8396 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
8398 gfc_conv_structure (&se
, expr
, 1);
8399 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
8400 TREE_STATIC (se
.expr
) = 1;
8404 if (expr
->expr_type
== EXPR_CONSTANT
)
8406 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
, expr
);
8407 TREE_STATIC (ctor
) = 1;
8413 gfc_init_se (&se
, NULL
);
8414 gfc_conv_constant (&se
, expr
);
8415 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
8422 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
8428 gfc_array_info
*lss_array
;
8435 gfc_start_block (&block
);
8437 /* Initialize the scalarizer. */
8438 gfc_init_loopinfo (&loop
);
8440 gfc_init_se (&lse
, NULL
);
8441 gfc_init_se (&rse
, NULL
);
8444 rss
= gfc_walk_expr (expr
);
8445 if (rss
== gfc_ss_terminator
)
8446 /* The rhs is scalar. Add a ss for the expression. */
8447 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
8449 /* Create a SS for the destination. */
8450 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
8452 lss_array
= &lss
->info
->data
.array
;
8453 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
8454 lss_array
->descriptor
= dest
;
8455 lss_array
->data
= gfc_conv_array_data (dest
);
8456 lss_array
->offset
= gfc_conv_array_offset (dest
);
8457 for (n
= 0; n
< cm
->as
->rank
; n
++)
8459 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
8460 lss_array
->stride
[n
] = gfc_index_one_node
;
8462 mpz_init (lss_array
->shape
[n
]);
8463 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
8464 cm
->as
->lower
[n
]->value
.integer
);
8465 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
8468 /* Associate the SS with the loop. */
8469 gfc_add_ss_to_loop (&loop
, lss
);
8470 gfc_add_ss_to_loop (&loop
, rss
);
8472 /* Calculate the bounds of the scalarization. */
8473 gfc_conv_ss_startstride (&loop
);
8475 /* Setup the scalarizing loops. */
8476 gfc_conv_loop_setup (&loop
, &expr
->where
);
8478 /* Setup the gfc_se structures. */
8479 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8480 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8483 gfc_mark_ss_chain_used (rss
, 1);
8485 gfc_mark_ss_chain_used (lss
, 1);
8487 /* Start the scalarized loop body. */
8488 gfc_start_scalarized_body (&loop
, &body
);
8490 gfc_conv_tmp_array_ref (&lse
);
8491 if (cm
->ts
.type
== BT_CHARACTER
)
8492 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
8494 gfc_conv_expr (&rse
, expr
);
8496 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
8497 gfc_add_expr_to_block (&body
, tmp
);
8499 gcc_assert (rse
.ss
== gfc_ss_terminator
);
8501 /* Generate the copying loops. */
8502 gfc_trans_scalarizing_loops (&loop
, &body
);
8504 /* Wrap the whole thing up. */
8505 gfc_add_block_to_block (&block
, &loop
.pre
);
8506 gfc_add_block_to_block (&block
, &loop
.post
);
8508 gcc_assert (lss_array
->shape
!= NULL
);
8509 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
8510 gfc_cleanup_loop (&loop
);
8512 return gfc_finish_block (&block
);
8517 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
8527 gfc_expr
*arg
= NULL
;
8529 gfc_start_block (&block
);
8530 gfc_init_se (&se
, NULL
);
8532 /* Get the descriptor for the expressions. */
8533 se
.want_pointer
= 0;
8534 gfc_conv_expr_descriptor (&se
, expr
);
8535 gfc_add_block_to_block (&block
, &se
.pre
);
8536 gfc_add_modify (&block
, dest
, se
.expr
);
8538 /* Deal with arrays of derived types with allocatable components. */
8539 if (gfc_bt_struct (cm
->ts
.type
)
8540 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
8541 // TODO: Fix caf_mode
8542 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
8545 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
8546 && CLASS_DATA(cm
)->attr
.allocatable
)
8548 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
8549 // TODO: Fix caf_mode
8550 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
8555 tmp
= TREE_TYPE (dest
);
8556 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8557 tmp
, expr
->rank
, NULL_TREE
);
8561 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
8562 TREE_TYPE(cm
->backend_decl
),
8563 cm
->as
->rank
, NULL_TREE
);
8565 gfc_add_expr_to_block (&block
, tmp
);
8566 gfc_add_block_to_block (&block
, &se
.post
);
8568 if (expr
->expr_type
!= EXPR_VARIABLE
)
8569 gfc_conv_descriptor_data_set (&block
, se
.expr
,
8572 /* We need to know if the argument of a conversion function is a
8573 variable, so that the correct lower bound can be used. */
8574 if (expr
->expr_type
== EXPR_FUNCTION
8575 && expr
->value
.function
.isym
8576 && expr
->value
.function
.isym
->conversion
8577 && expr
->value
.function
.actual
->expr
8578 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
8579 arg
= expr
->value
.function
.actual
->expr
;
8581 /* Obtain the array spec of full array references. */
8583 as
= gfc_get_full_arrayspec_from_expr (arg
);
8585 as
= gfc_get_full_arrayspec_from_expr (expr
);
8587 /* Shift the lbound and ubound of temporaries to being unity,
8588 rather than zero, based. Always calculate the offset. */
8589 offset
= gfc_conv_descriptor_offset_get (dest
);
8590 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
8591 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
8593 for (n
= 0; n
< expr
->rank
; n
++)
8598 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8599 TODO It looks as if gfc_conv_expr_descriptor should return
8600 the correct bounds and that the following should not be
8601 necessary. This would simplify gfc_conv_intrinsic_bound
8603 if (as
&& as
->lower
[n
])
8606 gfc_init_se (&lbse
, NULL
);
8607 gfc_conv_expr (&lbse
, as
->lower
[n
]);
8608 gfc_add_block_to_block (&block
, &lbse
.pre
);
8609 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
8613 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
8614 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
8618 lbound
= gfc_conv_descriptor_lbound_get (dest
,
8621 lbound
= gfc_index_one_node
;
8623 lbound
= fold_convert (gfc_array_index_type
, lbound
);
8625 /* Shift the bounds and set the offset accordingly. */
8626 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
8627 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8628 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
8629 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
8631 gfc_conv_descriptor_ubound_set (&block
, dest
,
8632 gfc_rank_cst
[n
], tmp
);
8633 gfc_conv_descriptor_lbound_set (&block
, dest
,
8634 gfc_rank_cst
[n
], lbound
);
8636 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8637 gfc_conv_descriptor_lbound_get (dest
,
8639 gfc_conv_descriptor_stride_get (dest
,
8641 gfc_add_modify (&block
, tmp2
, tmp
);
8642 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
8644 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
8649 /* If a conversion expression has a null data pointer
8650 argument, nullify the allocatable component. */
8654 if (arg
->symtree
->n
.sym
->attr
.allocatable
8655 || arg
->symtree
->n
.sym
->attr
.pointer
)
8657 non_null_expr
= gfc_finish_block (&block
);
8658 gfc_start_block (&block
);
8659 gfc_conv_descriptor_data_set (&block
, dest
,
8661 null_expr
= gfc_finish_block (&block
);
8662 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
8663 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
8664 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
8665 return build3_v (COND_EXPR
, tmp
,
8666 null_expr
, non_null_expr
);
8670 return gfc_finish_block (&block
);
8674 /* Allocate or reallocate scalar component, as necessary. */
8677 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
8687 tree lhs_cl_size
= NULL_TREE
;
8692 if (!expr2
|| expr2
->rank
)
8695 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8697 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8699 char name
[GFC_MAX_SYMBOL_LEN
+9];
8700 gfc_component
*strlen
;
8701 /* Use the rhs string length and the lhs element size. */
8702 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8703 if (!expr2
->ts
.u
.cl
->backend_decl
)
8705 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
8706 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
8709 size
= expr2
->ts
.u
.cl
->backend_decl
;
8711 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8713 sprintf (name
, "_%s_length", cm
->name
);
8714 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
8715 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
8716 gfc_charlen_type_node
,
8717 TREE_OPERAND (comp
, 0),
8718 strlen
->backend_decl
, NULL_TREE
);
8720 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
8721 tmp
= TYPE_SIZE_UNIT (tmp
);
8722 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8723 TREE_TYPE (tmp
), tmp
,
8724 fold_convert (TREE_TYPE (tmp
), size
));
8726 else if (cm
->ts
.type
== BT_CLASS
)
8728 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
8729 if (expr2
->ts
.type
== BT_DERIVED
)
8731 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
8732 size
= TYPE_SIZE_UNIT (tmp
);
8738 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
8739 gfc_add_vptr_component (e2vtab
);
8740 gfc_add_size_component (e2vtab
);
8741 gfc_init_se (&se
, NULL
);
8742 gfc_conv_expr (&se
, e2vtab
);
8743 gfc_add_block_to_block (block
, &se
.pre
);
8744 size
= fold_convert (size_type_node
, se
.expr
);
8745 gfc_free_expr (e2vtab
);
8747 size_in_bytes
= size
;
8751 /* Otherwise use the length in bytes of the rhs. */
8752 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
8753 size_in_bytes
= size
;
8756 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8757 size_in_bytes
, size_one_node
);
8759 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
8761 tmp
= build_call_expr_loc (input_location
,
8762 builtin_decl_explicit (BUILT_IN_CALLOC
),
8763 2, build_one_cst (size_type_node
),
8765 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
8766 gfc_add_modify (block
, comp
, tmp
);
8770 tmp
= build_call_expr_loc (input_location
,
8771 builtin_decl_explicit (BUILT_IN_MALLOC
),
8773 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
8774 ptr
= gfc_class_data_get (comp
);
8777 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
8778 gfc_add_modify (block
, ptr
, tmp
);
8781 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8782 /* Update the lhs character length. */
8783 gfc_add_modify (block
, lhs_cl_size
,
8784 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
8788 /* Assign a single component of a derived type constructor. */
8791 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
8792 gfc_symbol
*sym
, bool init
)
8800 gfc_start_block (&block
);
8802 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
8804 /* Only care about pointers here, not about allocatables. */
8805 gfc_init_se (&se
, NULL
);
8806 /* Pointer component. */
8807 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8808 && !cm
->attr
.proc_pointer
)
8810 /* Array pointer. */
8811 if (expr
->expr_type
== EXPR_NULL
)
8812 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8815 se
.direct_byref
= 1;
8817 gfc_conv_expr_descriptor (&se
, expr
);
8818 gfc_add_block_to_block (&block
, &se
.pre
);
8819 gfc_add_block_to_block (&block
, &se
.post
);
8824 /* Scalar pointers. */
8825 se
.want_pointer
= 1;
8826 gfc_conv_expr (&se
, expr
);
8827 gfc_add_block_to_block (&block
, &se
.pre
);
8829 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8830 && expr
->symtree
->n
.sym
->attr
.dummy
)
8831 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8833 gfc_add_modify (&block
, dest
,
8834 fold_convert (TREE_TYPE (dest
), se
.expr
));
8835 gfc_add_block_to_block (&block
, &se
.post
);
8838 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
8840 /* NULL initialization for CLASS components. */
8841 tmp
= gfc_trans_structure_assign (dest
,
8842 gfc_class_initializer (&cm
->ts
, expr
),
8844 gfc_add_expr_to_block (&block
, tmp
);
8846 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
8847 && !cm
->attr
.proc_pointer
)
8849 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8850 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
8851 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
8853 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
8854 gfc_add_expr_to_block (&block
, tmp
);
8858 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
8859 gfc_add_expr_to_block (&block
, tmp
);
8862 else if (cm
->ts
.type
== BT_CLASS
8863 && CLASS_DATA (cm
)->attr
.dimension
8864 && CLASS_DATA (cm
)->attr
.allocatable
8865 && expr
->ts
.type
== BT_DERIVED
)
8867 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8868 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8869 tmp
= gfc_class_vptr_get (dest
);
8870 gfc_add_modify (&block
, tmp
,
8871 fold_convert (TREE_TYPE (tmp
), vtab
));
8872 tmp
= gfc_class_data_get (dest
);
8873 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
8874 gfc_add_expr_to_block (&block
, tmp
);
8876 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
8878 /* NULL initialization for allocatable components. */
8879 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
8880 null_pointer_node
));
8882 else if (init
&& (cm
->attr
.allocatable
8883 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
8884 && expr
->ts
.type
!= BT_CLASS
)))
8886 /* Take care about non-array allocatable components here. The alloc_*
8887 routine below is motivated by the alloc_scalar_allocatable_for_
8888 assignment() routine, but with the realloc portions removed and
8890 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
8895 /* The remainder of these instructions follow the if (cm->attr.pointer)
8896 if (!cm->attr.dimension) part above. */
8897 gfc_init_se (&se
, NULL
);
8898 gfc_conv_expr (&se
, expr
);
8899 gfc_add_block_to_block (&block
, &se
.pre
);
8901 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
8902 && expr
->symtree
->n
.sym
->attr
.dummy
)
8903 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
8905 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
8907 tmp
= gfc_class_data_get (dest
);
8908 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
8909 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
8910 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
8911 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
8912 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
8915 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
8917 /* For deferred strings insert a memcpy. */
8918 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
8921 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
8922 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
8924 : expr
->ts
.u
.cl
->backend_decl
);
8925 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
8926 gfc_add_expr_to_block (&block
, tmp
);
8929 gfc_add_modify (&block
, tmp
,
8930 fold_convert (TREE_TYPE (tmp
), se
.expr
));
8931 gfc_add_block_to_block (&block
, &se
.post
);
8933 else if (expr
->ts
.type
== BT_UNION
)
8936 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
8937 /* We mark that the entire union should be initialized with a contrived
8938 EXPR_NULL expression at the beginning. */
8939 if (c
!= NULL
&& c
->n
.component
== NULL
8940 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
8942 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8943 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
8944 gfc_add_expr_to_block (&block
, tmp
);
8945 c
= gfc_constructor_next (c
);
8947 /* The following constructor expression, if any, represents a specific
8948 map intializer, as given by the user. */
8949 if (c
!= NULL
&& c
->expr
!= NULL
)
8951 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
8952 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8953 gfc_add_expr_to_block (&block
, tmp
);
8956 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
8958 if (expr
->expr_type
!= EXPR_STRUCTURE
)
8960 tree dealloc
= NULL_TREE
;
8961 gfc_init_se (&se
, NULL
);
8962 gfc_conv_expr (&se
, expr
);
8963 gfc_add_block_to_block (&block
, &se
.pre
);
8964 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8965 expression in a temporary variable and deallocate the allocatable
8966 components. Then we can the copy the expression to the result. */
8967 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8968 && expr
->expr_type
!= EXPR_VARIABLE
)
8970 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
8971 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8974 gfc_add_modify (&block
, dest
,
8975 fold_convert (TREE_TYPE (dest
), se
.expr
));
8976 if (cm
->ts
.u
.derived
->attr
.alloc_comp
8977 && expr
->expr_type
!= EXPR_NULL
)
8979 // TODO: Fix caf_mode
8980 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
8981 dest
, expr
->rank
, 0);
8982 gfc_add_expr_to_block (&block
, tmp
);
8983 if (dealloc
!= NULL_TREE
)
8984 gfc_add_expr_to_block (&block
, dealloc
);
8986 gfc_add_block_to_block (&block
, &se
.post
);
8990 /* Nested constructors. */
8991 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
8992 gfc_add_expr_to_block (&block
, tmp
);
8995 else if (gfc_deferred_strlen (cm
, &tmp
))
8999 gcc_assert (strlen
);
9000 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
9002 TREE_OPERAND (dest
, 0),
9005 if (expr
->expr_type
== EXPR_NULL
)
9007 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
9008 gfc_add_modify (&block
, dest
, tmp
);
9009 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
9010 gfc_add_modify (&block
, strlen
, tmp
);
9015 gfc_init_se (&se
, NULL
);
9016 gfc_conv_expr (&se
, expr
);
9017 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
9018 tmp
= build_call_expr_loc (input_location
,
9019 builtin_decl_explicit (BUILT_IN_MALLOC
),
9021 gfc_add_modify (&block
, dest
,
9022 fold_convert (TREE_TYPE (dest
), tmp
));
9023 gfc_add_modify (&block
, strlen
,
9024 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
9025 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
9026 gfc_add_expr_to_block (&block
, tmp
);
9029 else if (!cm
->attr
.artificial
)
9031 /* Scalar component (excluding deferred parameters). */
9032 gfc_init_se (&se
, NULL
);
9033 gfc_init_se (&lse
, NULL
);
9035 gfc_conv_expr (&se
, expr
);
9036 if (cm
->ts
.type
== BT_CHARACTER
)
9037 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
9039 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
9040 gfc_add_expr_to_block (&block
, tmp
);
9042 return gfc_finish_block (&block
);
9045 /* Assign a derived type constructor to a variable. */
9048 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
9057 gfc_start_block (&block
);
9059 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
9060 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
9061 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
9065 gfc_init_se (&se
, NULL
);
9066 gfc_init_se (&lse
, NULL
);
9067 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
9069 gfc_add_modify (&block
, lse
.expr
,
9070 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
9072 return gfc_finish_block (&block
);
9075 /* Make sure that the derived type has been completely built. */
9076 if (!expr
->ts
.u
.derived
->backend_decl
9077 || !TYPE_FIELDS (expr
->ts
.u
.derived
->backend_decl
))
9079 tmp
= gfc_typenode_for_spec (&expr
->ts
);
9083 cm
= expr
->ts
.u
.derived
->components
;
9087 gfc_init_se (&se
, NULL
);
9089 for (c
= gfc_constructor_first (expr
->value
.constructor
);
9090 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
9092 /* Skip absent members in default initializers. */
9093 if (!c
->expr
&& !cm
->attr
.allocatable
)
9096 /* Register the component with the caf-lib before it is initialized.
9097 Register only allocatable components, that are not coarray'ed
9098 components (%comp[*]). Only register when the constructor is not the
9100 if (coarray
&& !cm
->attr
.codimension
9101 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
9102 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
9104 tree token
, desc
, size
;
9105 bool is_array
= cm
->ts
.type
== BT_CLASS
9106 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
9108 field
= cm
->backend_decl
;
9109 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
9110 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
9111 if (cm
->ts
.type
== BT_CLASS
)
9112 field
= gfc_class_data_get (field
);
9114 token
= is_array
? gfc_conv_descriptor_token (field
)
9115 : fold_build3_loc (input_location
, COMPONENT_REF
,
9116 TREE_TYPE (cm
->caf_token
), dest
,
9117 cm
->caf_token
, NULL_TREE
);
9121 /* The _caf_register routine looks at the rank of the array
9122 descriptor to decide whether the data registered is an array
9124 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
9126 /* When the rank is not known just set a positive rank, which
9127 suffices to recognize the data as array. */
9130 size
= build_zero_cst (size_type_node
);
9132 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
9133 build_int_cst (signed_char_type_node
, rank
));
9137 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
9138 cm
->ts
.type
== BT_CLASS
9139 ? CLASS_DATA (cm
)->attr
9141 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
9143 gfc_add_block_to_block (&block
, &se
.pre
);
9144 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
9145 7, size
, build_int_cst (
9147 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
9148 gfc_build_addr_expr (pvoid_type_node
,
9150 gfc_build_addr_expr (NULL_TREE
, desc
),
9151 null_pointer_node
, null_pointer_node
,
9153 gfc_add_expr_to_block (&block
, tmp
);
9155 field
= cm
->backend_decl
;
9157 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
9158 dest
, field
, NULL_TREE
);
9161 gfc_expr
*e
= gfc_get_null_expr (NULL
);
9162 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
9167 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
9168 expr
->ts
.u
.derived
, init
);
9169 gfc_add_expr_to_block (&block
, tmp
);
9171 return gfc_finish_block (&block
);
9175 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
9176 gfc_component
*un
, gfc_expr
*init
)
9178 gfc_constructor
*ctor
;
9180 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
9183 ctor
= gfc_constructor_first (init
->value
.constructor
);
9185 if (ctor
== NULL
|| ctor
->expr
== NULL
)
9188 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
9190 /* If we have an 'initialize all' constructor, do it first. */
9191 if (ctor
->expr
->expr_type
== EXPR_NULL
)
9193 tree union_type
= TREE_TYPE (un
->backend_decl
);
9194 tree val
= build_constructor (union_type
, NULL
);
9195 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
9196 ctor
= gfc_constructor_next (ctor
);
9199 /* Add the map initializer on top. */
9200 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
9202 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
9203 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
9204 TREE_TYPE (un
->backend_decl
),
9205 un
->attr
.dimension
, un
->attr
.pointer
,
9206 un
->attr
.proc_pointer
);
9207 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
9211 /* Build an expression for a constructor. If init is nonzero then
9212 this is part of a static variable initializer. */
9215 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
9222 vec
<constructor_elt
, va_gc
> *v
= NULL
;
9224 gcc_assert (se
->ss
== NULL
);
9225 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
9226 type
= gfc_typenode_for_spec (&expr
->ts
);
9230 /* Create a temporary variable and fill it in. */
9231 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
9232 /* The symtree in expr is NULL, if the code to generate is for
9233 initializing the static members only. */
9234 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
9236 gfc_add_expr_to_block (&se
->pre
, tmp
);
9240 cm
= expr
->ts
.u
.derived
->components
;
9242 for (c
= gfc_constructor_first (expr
->value
.constructor
);
9243 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
9245 /* Skip absent members in default initializers and allocatable
9246 components. Although the latter have a default initializer
9247 of EXPR_NULL,... by default, the static nullify is not needed
9248 since this is done every time we come into scope. */
9249 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
9252 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
9253 && strcmp (cm
->name
, "_extends") == 0
9254 && cm
->initializer
->symtree
)
9258 vtabs
= cm
->initializer
->symtree
->n
.sym
;
9259 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
9260 vtab
= unshare_expr_without_location (vtab
);
9261 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
9263 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
9265 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
9266 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
9267 fold_convert (TREE_TYPE (cm
->backend_decl
),
9270 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
9271 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
9272 fold_convert (TREE_TYPE (cm
->backend_decl
),
9273 integer_zero_node
));
9274 else if (cm
->ts
.type
== BT_UNION
)
9275 gfc_conv_union_initializer (v
, cm
, c
->expr
);
9278 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
9279 TREE_TYPE (cm
->backend_decl
),
9280 cm
->attr
.dimension
, cm
->attr
.pointer
,
9281 cm
->attr
.proc_pointer
);
9282 val
= unshare_expr_without_location (val
);
9284 /* Append it to the constructor list. */
9285 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
9289 se
->expr
= build_constructor (type
, v
);
9291 TREE_CONSTANT (se
->expr
) = 1;
9295 /* Translate a substring expression. */
9298 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
9304 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
9306 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
9307 expr
->value
.character
.length
,
9308 expr
->value
.character
.string
);
9310 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
9311 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
9314 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
9318 /* Entry point for expression translation. Evaluates a scalar quantity.
9319 EXPR is the expression to be translated, and SE is the state structure if
9320 called from within the scalarized. */
9323 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
9328 if (ss
&& ss
->info
->expr
== expr
9329 && (ss
->info
->type
== GFC_SS_SCALAR
9330 || ss
->info
->type
== GFC_SS_REFERENCE
))
9332 gfc_ss_info
*ss_info
;
9335 /* Substitute a scalar expression evaluated outside the scalarization
9337 se
->expr
= ss_info
->data
.scalar
.value
;
9338 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
9339 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9341 se
->string_length
= ss_info
->string_length
;
9342 gfc_advance_se_ss_chain (se
);
9346 /* We need to convert the expressions for the iso_c_binding derived types.
9347 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
9348 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
9349 typespec for the C_PTR and C_FUNPTR symbols, which has already been
9350 updated to be an integer with a kind equal to the size of a (void *). */
9351 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
9352 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
9354 if (expr
->expr_type
== EXPR_VARIABLE
9355 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
9356 || expr
->symtree
->n
.sym
->intmod_sym_id
9357 == ISOCBINDING_NULL_FUNPTR
))
9359 /* Set expr_type to EXPR_NULL, which will result in
9360 null_pointer_node being used below. */
9361 expr
->expr_type
= EXPR_NULL
;
9365 /* Update the type/kind of the expression to be what the new
9366 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
9367 expr
->ts
.type
= BT_INTEGER
;
9368 expr
->ts
.f90_type
= BT_VOID
;
9369 expr
->ts
.kind
= gfc_index_integer_kind
;
9373 gfc_fix_class_refs (expr
);
9375 switch (expr
->expr_type
)
9378 gfc_conv_expr_op (se
, expr
);
9382 gfc_conv_function_expr (se
, expr
);
9386 gfc_conv_constant (se
, expr
);
9390 gfc_conv_variable (se
, expr
);
9394 se
->expr
= null_pointer_node
;
9397 case EXPR_SUBSTRING
:
9398 gfc_conv_substring_expr (se
, expr
);
9401 case EXPR_STRUCTURE
:
9402 gfc_conv_structure (se
, expr
, 0);
9406 gfc_conv_array_constructor_expr (se
, expr
);
9415 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9416 of an assignment. */
9418 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
9420 gfc_conv_expr (se
, expr
);
9421 /* All numeric lvalues should have empty post chains. If not we need to
9422 figure out a way of rewriting an lvalue so that it has no post chain. */
9423 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
9426 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9427 numeric expressions. Used for scalar values where inserting cleanup code
9430 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
9434 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
9435 gfc_conv_expr (se
, expr
);
9438 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9439 gfc_add_modify (&se
->pre
, val
, se
->expr
);
9441 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9445 /* Helper to translate an expression and convert it to a particular type. */
9447 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
9449 gfc_conv_expr_val (se
, expr
);
9450 se
->expr
= convert (type
, se
->expr
);
9454 /* Converts an expression so that it can be passed by reference. Scalar
9458 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
, bool add_clobber
)
9464 if (ss
&& ss
->info
->expr
== expr
9465 && ss
->info
->type
== GFC_SS_REFERENCE
)
9467 /* Returns a reference to the scalar evaluated outside the loop
9469 gfc_conv_expr (se
, expr
);
9471 if (expr
->ts
.type
== BT_CHARACTER
9472 && expr
->expr_type
!= EXPR_FUNCTION
)
9473 gfc_conv_string_parameter (se
);
9475 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
9480 if (expr
->ts
.type
== BT_CHARACTER
)
9482 gfc_conv_expr (se
, expr
);
9483 gfc_conv_string_parameter (se
);
9487 if (expr
->expr_type
== EXPR_VARIABLE
)
9489 se
->want_pointer
= 1;
9490 gfc_conv_expr (se
, expr
);
9493 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9494 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9495 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9498 else if (add_clobber
&& expr
->ref
== NULL
)
9502 /* FIXME: This fails if var is passed by reference, see PR
9504 var
= expr
->symtree
->n
.sym
->backend_decl
;
9505 clobber
= build_clobber (TREE_TYPE (var
));
9506 gfc_add_modify (&se
->pre
, var
, clobber
);
9511 if (expr
->expr_type
== EXPR_FUNCTION
9512 && ((expr
->value
.function
.esym
9513 && expr
->value
.function
.esym
->result
9514 && expr
->value
.function
.esym
->result
->attr
.pointer
9515 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
9516 || (!expr
->value
.function
.esym
&& !expr
->ref
9517 && expr
->symtree
->n
.sym
->attr
.pointer
9518 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
9520 se
->want_pointer
= 1;
9521 gfc_conv_expr (se
, expr
);
9522 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9523 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9528 gfc_conv_expr (se
, expr
);
9530 /* Create a temporary var to hold the value. */
9531 if (TREE_CONSTANT (se
->expr
))
9533 tree tmp
= se
->expr
;
9534 STRIP_TYPE_NOPS (tmp
);
9535 var
= build_decl (input_location
,
9536 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
9537 DECL_INITIAL (var
) = tmp
;
9538 TREE_STATIC (var
) = 1;
9543 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
9544 gfc_add_modify (&se
->pre
, var
, se
->expr
);
9547 if (!expr
->must_finalize
)
9548 gfc_add_block_to_block (&se
->pre
, &se
->post
);
9550 /* Take the address of that value. */
9551 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
9555 /* Get the _len component for an unlimited polymorphic expression. */
9558 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
9561 gfc_ref
*ref
= expr
->ref
;
9563 gfc_init_se (&se
, NULL
);
9564 while (ref
&& ref
->next
)
9566 gfc_add_len_component (expr
);
9567 gfc_conv_expr (&se
, expr
);
9568 gfc_add_block_to_block (block
, &se
.pre
);
9569 gcc_assert (se
.post
.head
== NULL_TREE
);
9572 gfc_free_ref_list (ref
->next
);
9577 gfc_free_ref_list (expr
->ref
);
9584 /* Assign _vptr and _len components as appropriate. BLOCK should be a
9585 statement-list outside of the scalarizer-loop. When code is generated, that
9586 depends on the scalarized expression, it is added to RSE.PRE.
9587 Returns le's _vptr tree and when set the len expressions in to_lenp and
9588 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9592 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
9593 gfc_expr
* re
, gfc_se
*rse
,
9594 tree
* to_lenp
, tree
* from_lenp
)
9597 gfc_expr
* vptr_expr
;
9598 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
9599 bool set_vptr
= false, temp_rhs
= false;
9600 stmtblock_t
*pre
= block
;
9601 tree class_expr
= NULL_TREE
;
9603 /* Create a temporary for complicated expressions. */
9604 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
9605 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
9607 if (re
->ts
.type
== BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9608 class_expr
= gfc_get_class_from_expr (rse
->expr
);
9611 pre
= &rse
->loop
->pre
;
9615 if (class_expr
!= NULL_TREE
&& UNLIMITED_POLY (re
))
9617 tmp
= TREE_OPERAND (rse
->expr
, 0);
9618 tmp
= gfc_create_var (TREE_TYPE (tmp
), "rhs");
9619 gfc_add_modify (&rse
->pre
, tmp
, TREE_OPERAND (rse
->expr
, 0));
9623 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
9624 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
9631 /* Get the _vptr for the left-hand side expression. */
9632 gfc_init_se (&se
, NULL
);
9633 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
9634 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
9636 /* Care about _len for unlimited polymorphic entities. */
9637 if (UNLIMITED_POLY (vptr_expr
)
9638 || (vptr_expr
->ts
.type
== BT_DERIVED
9639 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9640 to_len
= trans_get_upoly_len (block
, vptr_expr
);
9641 gfc_add_vptr_component (vptr_expr
);
9645 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9646 se
.want_pointer
= 1;
9647 gfc_conv_expr (&se
, vptr_expr
);
9648 gfc_free_expr (vptr_expr
);
9649 gfc_add_block_to_block (block
, &se
.pre
);
9650 gcc_assert (se
.post
.head
== NULL_TREE
);
9652 STRIP_NOPS (lhs_vptr
);
9654 /* Set the _vptr only when the left-hand side of the assignment is a
9658 /* Get the vptr from the rhs expression only, when it is variable.
9659 Functions are expected to be assigned to a temporary beforehand. */
9660 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
9661 ? gfc_find_and_cut_at_last_class_ref (re
)
9663 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
9665 if (to_len
!= NULL_TREE
)
9667 /* Get the _len information from the rhs. */
9668 if (UNLIMITED_POLY (vptr_expr
)
9669 || (vptr_expr
->ts
.type
== BT_DERIVED
9670 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
9671 from_len
= trans_get_upoly_len (block
, vptr_expr
);
9673 gfc_add_vptr_component (vptr_expr
);
9677 if (re
->expr_type
== EXPR_VARIABLE
9678 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
9679 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
9680 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
9681 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
9682 re
->symtree
->n
.sym
->backend_decl
))))
9685 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
9686 re
->symtree
->n
.sym
->backend_decl
));
9688 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
9689 re
->symtree
->n
.sym
->backend_decl
));
9691 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
9696 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
)))
9697 tmp
= gfc_get_class_from_expr (rse
->expr
);
9701 se
.expr
= gfc_class_vptr_get (tmp
);
9702 if (UNLIMITED_POLY (re
))
9703 from_len
= gfc_class_len_get (tmp
);
9706 else if (re
->expr_type
!= EXPR_NULL
)
9707 /* Only when rhs is non-NULL use its declared type for vptr
9709 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
9711 /* When the rhs is NULL use the vtab of lhs' declared type. */
9712 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
9717 gfc_init_se (&se
, NULL
);
9718 se
.want_pointer
= 1;
9719 gfc_conv_expr (&se
, vptr_expr
);
9720 gfc_free_expr (vptr_expr
);
9721 gfc_add_block_to_block (block
, &se
.pre
);
9722 gcc_assert (se
.post
.head
== NULL_TREE
);
9724 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
9727 if (to_len
!= NULL_TREE
)
9729 /* The _len component needs to be set. Figure how to get the
9730 value of the right-hand side. */
9731 if (from_len
== NULL_TREE
)
9733 if (rse
->string_length
!= NULL_TREE
)
9734 from_len
= rse
->string_length
;
9735 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
9737 gfc_init_se (&se
, NULL
);
9738 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
9739 gfc_add_block_to_block (block
, &se
.pre
);
9740 gcc_assert (se
.post
.head
== NULL_TREE
);
9741 from_len
= gfc_evaluate_now (se
.expr
, block
);
9744 from_len
= build_zero_cst (gfc_charlen_type_node
);
9746 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
9751 /* Return the _len trees only, when requested. */
9755 *from_lenp
= from_len
;
9760 /* Assign tokens for pointer components. */
9763 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
9766 symbol_attribute lhs_attr
, rhs_attr
;
9767 tree tmp
, lhs_tok
, rhs_tok
;
9768 /* Flag to indicated component refs on the rhs. */
9771 lhs_attr
= gfc_caf_attr (expr1
);
9772 if (expr2
->expr_type
!= EXPR_NULL
)
9774 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
9775 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
9777 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9778 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9781 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
9785 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
9786 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
9789 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9791 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
9792 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9795 else if (lhs_attr
.codimension
)
9797 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
9798 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
9799 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9800 lhs_tok
, null_pointer_node
);
9801 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
9806 /* Do everything that is needed for a CLASS function expr2. */
9809 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
9810 gfc_expr
*expr1
, gfc_expr
*expr2
)
9812 tree expr1_vptr
= NULL_TREE
;
9815 gfc_conv_function_expr (rse
, expr2
);
9816 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
9818 if (expr1
->ts
.type
!= BT_CLASS
)
9819 rse
->expr
= gfc_class_data_get (rse
->expr
);
9822 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
9825 gfc_add_block_to_block (block
, &rse
->pre
);
9826 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
9827 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
9829 gfc_add_modify (&lse
->pre
, expr1_vptr
,
9830 fold_convert (TREE_TYPE (expr1_vptr
),
9831 gfc_class_vptr_get (tmp
)));
9832 rse
->expr
= gfc_class_data_get (tmp
);
9840 gfc_trans_pointer_assign (gfc_code
* code
)
9842 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
9846 /* Generate code for a pointer assignment. */
9849 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
9856 tree expr1_vptr
= NULL_TREE
;
9857 bool scalar
, non_proc_ptr_assign
;
9860 gfc_start_block (&block
);
9862 gfc_init_se (&lse
, NULL
);
9864 /* Usually testing whether this is not a proc pointer assignment. */
9865 non_proc_ptr_assign
= !(gfc_expr_attr (expr1
).proc_pointer
9866 && expr2
->expr_type
== EXPR_VARIABLE
9867 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
9869 /* Check whether the expression is a scalar or not; we cannot use
9870 expr1->rank as it can be nonzero for proc pointers. */
9871 ss
= gfc_walk_expr (expr1
);
9872 scalar
= ss
== gfc_ss_terminator
;
9874 gfc_free_ss_chain (ss
);
9876 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
9877 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_ptr_assign
)
9879 gfc_add_data_component (expr2
);
9880 /* The following is required as gfc_add_data_component doesn't
9881 update ts.type if there is a trailing REF_ARRAY. */
9882 expr2
->ts
.type
= BT_DERIVED
;
9887 /* Scalar pointers. */
9888 lse
.want_pointer
= 1;
9889 gfc_conv_expr (&lse
, expr1
);
9890 gfc_init_se (&rse
, NULL
);
9891 rse
.want_pointer
= 1;
9892 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
9893 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
9895 gfc_conv_expr (&rse
, expr2
);
9897 if (non_proc_ptr_assign
&& expr1
->ts
.type
== BT_CLASS
)
9899 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
9901 lse
.expr
= gfc_class_data_get (lse
.expr
);
9904 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
9905 && expr1
->symtree
->n
.sym
->attr
.dummy
)
9906 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
9909 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
9910 && expr2
->symtree
->n
.sym
->attr
.dummy
)
9911 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
9914 gfc_add_block_to_block (&block
, &lse
.pre
);
9915 gfc_add_block_to_block (&block
, &rse
.pre
);
9917 /* Check character lengths if character expression. The test is only
9918 really added if -fbounds-check is enabled. Exclude deferred
9919 character length lefthand sides. */
9920 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
9921 && !expr1
->ts
.deferred
9922 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
9923 && !gfc_is_proc_ptr_comp (expr1
))
9925 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
9926 gcc_assert (lse
.string_length
&& rse
.string_length
);
9927 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
9928 lse
.string_length
, rse
.string_length
,
9932 /* The assignment to an deferred character length sets the string
9933 length to that of the rhs. */
9934 if (expr1
->ts
.deferred
)
9936 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
9937 gfc_add_modify (&block
, lse
.string_length
,
9938 fold_convert (TREE_TYPE (lse
.string_length
),
9939 rse
.string_length
));
9940 else if (lse
.string_length
!= NULL
)
9941 gfc_add_modify (&block
, lse
.string_length
,
9942 build_zero_cst (TREE_TYPE (lse
.string_length
)));
9945 gfc_add_modify (&block
, lse
.expr
,
9946 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
9948 /* Also set the tokens for pointer components in derived typed
9950 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9951 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
9953 gfc_add_block_to_block (&block
, &rse
.post
);
9954 gfc_add_block_to_block (&block
, &lse
.post
);
9961 tree strlen_rhs
= NULL_TREE
;
9963 /* Array pointer. Find the last reference on the LHS and if it is an
9964 array section ref, we're dealing with bounds remapping. In this case,
9965 set it to AR_FULL so that gfc_conv_expr_descriptor does
9966 not see it and process the bounds remapping afterwards explicitly. */
9967 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
9968 if (!remap
->next
&& remap
->type
== REF_ARRAY
9969 && remap
->u
.ar
.type
== AR_SECTION
)
9971 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
9973 if (remap
&& expr2
->expr_type
== EXPR_NULL
)
9975 gfc_error ("If bounds remapping is specified at %L, "
9976 "the pointer target shall not be NULL", &expr1
->where
);
9980 gfc_init_se (&lse
, NULL
);
9982 lse
.descriptor_only
= 1;
9983 gfc_conv_expr_descriptor (&lse
, expr1
);
9984 strlen_lhs
= lse
.string_length
;
9987 if (expr2
->expr_type
== EXPR_NULL
)
9989 /* Just set the data pointer to null. */
9990 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
9992 else if (rank_remap
)
9994 /* If we are rank-remapping, just get the RHS's descriptor and
9995 process this later on. */
9996 gfc_init_se (&rse
, NULL
);
9997 rse
.direct_byref
= 1;
9998 rse
.byref_noassign
= 1;
10000 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
10001 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
10003 else if (expr2
->expr_type
== EXPR_FUNCTION
)
10005 tree bound
[GFC_MAX_DIMENSIONS
];
10008 for (i
= 0; i
< expr2
->rank
; i
++)
10009 bound
[i
] = NULL_TREE
;
10010 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
10011 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
10013 GFC_ARRAY_POINTER_CONT
, false);
10014 tmp
= gfc_create_var (tmp
, "ptrtemp");
10015 rse
.descriptor_only
= 0;
10017 rse
.direct_byref
= 1;
10018 gfc_conv_expr_descriptor (&rse
, expr2
);
10019 strlen_rhs
= rse
.string_length
;
10024 gfc_conv_expr_descriptor (&rse
, expr2
);
10025 strlen_rhs
= rse
.string_length
;
10026 if (expr1
->ts
.type
== BT_CLASS
)
10027 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
10032 else if (expr2
->expr_type
== EXPR_VARIABLE
)
10034 /* Assign directly to the LHS's descriptor. */
10035 lse
.descriptor_only
= 0;
10036 lse
.direct_byref
= 1;
10037 gfc_conv_expr_descriptor (&lse
, expr2
);
10038 strlen_rhs
= lse
.string_length
;
10039 gfc_init_se (&rse
, NULL
);
10041 if (expr1
->ts
.type
== BT_CLASS
)
10043 rse
.expr
= NULL_TREE
;
10044 rse
.string_length
= strlen_rhs
;
10045 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
10051 /* If the target is not a whole array, use the target array
10052 reference for remap. */
10053 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
10054 if (remap
->type
== REF_ARRAY
10055 && remap
->u
.ar
.type
== AR_FULL
10060 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
10062 gfc_init_se (&rse
, NULL
);
10063 rse
.want_pointer
= 1;
10064 gfc_conv_function_expr (&rse
, expr2
);
10065 if (expr1
->ts
.type
!= BT_CLASS
)
10067 rse
.expr
= gfc_class_data_get (rse
.expr
);
10068 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
10069 /* Set the lhs span. */
10070 tmp
= TREE_TYPE (rse
.expr
);
10071 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
10072 tmp
= fold_convert (gfc_array_index_type
, tmp
);
10073 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
10077 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
10080 gfc_add_block_to_block (&block
, &rse
.pre
);
10081 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
10082 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
10084 gfc_add_modify (&lse
.pre
, expr1_vptr
,
10085 fold_convert (TREE_TYPE (expr1_vptr
),
10086 gfc_class_vptr_get (tmp
)));
10087 rse
.expr
= gfc_class_data_get (tmp
);
10088 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
10093 /* Assign to a temporary descriptor and then copy that
10094 temporary to the pointer. */
10095 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
10096 lse
.descriptor_only
= 0;
10098 lse
.direct_byref
= 1;
10099 gfc_conv_expr_descriptor (&lse
, expr2
);
10100 strlen_rhs
= lse
.string_length
;
10101 gfc_add_modify (&lse
.pre
, desc
, tmp
);
10104 if (expr1
->ts
.type
== BT_CHARACTER
10105 && expr1
->symtree
->n
.sym
->ts
.deferred
10106 && expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
10107 && VAR_P (expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
))
10109 tmp
= expr1
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
10110 if (expr2
->expr_type
!= EXPR_NULL
)
10111 gfc_add_modify (&block
, tmp
,
10112 fold_convert (TREE_TYPE (tmp
), strlen_rhs
));
10114 gfc_add_modify (&block
, tmp
, build_zero_cst (TREE_TYPE (tmp
)));
10117 gfc_add_block_to_block (&block
, &lse
.pre
);
10119 gfc_add_block_to_block (&block
, &rse
.pre
);
10121 /* If we do bounds remapping, update LHS descriptor accordingly. */
10125 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
10129 /* Do rank remapping. We already have the RHS's descriptor
10130 converted in rse and now have to build the correct LHS
10131 descriptor for it. */
10133 tree dtype
, data
, span
;
10135 tree lbound
, ubound
;
10138 dtype
= gfc_conv_descriptor_dtype (desc
);
10139 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
10140 gfc_add_modify (&block
, dtype
, tmp
);
10142 /* Copy data pointer. */
10143 data
= gfc_conv_descriptor_data_get (rse
.expr
);
10144 gfc_conv_descriptor_data_set (&block
, desc
, data
);
10146 /* Copy the span. */
10147 if (TREE_CODE (rse
.expr
) == VAR_DECL
10148 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
10149 span
= gfc_conv_descriptor_span_get (rse
.expr
);
10152 tmp
= TREE_TYPE (rse
.expr
);
10153 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
10154 span
= fold_convert (gfc_array_index_type
, tmp
);
10156 gfc_conv_descriptor_span_set (&block
, desc
, span
);
10158 /* Copy offset but adjust it such that it would correspond
10159 to a lbound of zero. */
10160 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
10161 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
10163 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
10164 gfc_rank_cst
[dim
]);
10165 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
10166 gfc_rank_cst
[dim
]);
10167 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10168 gfc_array_index_type
, stride
, lbound
);
10169 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
10170 gfc_array_index_type
, offs
, tmp
);
10172 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
10174 /* Set the bounds as declared for the LHS and calculate strides as
10175 well as another offset update accordingly. */
10176 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
10178 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
10183 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
10185 /* Convert declared bounds. */
10186 gfc_init_se (&lower_se
, NULL
);
10187 gfc_init_se (&upper_se
, NULL
);
10188 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
10189 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
10191 gfc_add_block_to_block (&block
, &lower_se
.pre
);
10192 gfc_add_block_to_block (&block
, &upper_se
.pre
);
10194 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
10195 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
10197 lbound
= gfc_evaluate_now (lbound
, &block
);
10198 ubound
= gfc_evaluate_now (ubound
, &block
);
10200 gfc_add_block_to_block (&block
, &lower_se
.post
);
10201 gfc_add_block_to_block (&block
, &upper_se
.post
);
10203 /* Set bounds in descriptor. */
10204 gfc_conv_descriptor_lbound_set (&block
, desc
,
10205 gfc_rank_cst
[dim
], lbound
);
10206 gfc_conv_descriptor_ubound_set (&block
, desc
,
10207 gfc_rank_cst
[dim
], ubound
);
10210 stride
= gfc_evaluate_now (stride
, &block
);
10211 gfc_conv_descriptor_stride_set (&block
, desc
,
10212 gfc_rank_cst
[dim
], stride
);
10214 /* Update offset. */
10215 offs
= gfc_conv_descriptor_offset_get (desc
);
10216 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10217 gfc_array_index_type
, lbound
, stride
);
10218 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
10219 gfc_array_index_type
, offs
, tmp
);
10220 offs
= gfc_evaluate_now (offs
, &block
);
10221 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
10223 /* Update stride. */
10224 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
10225 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
10226 gfc_array_index_type
, stride
, tmp
);
10231 /* Bounds remapping. Just shift the lower bounds. */
10233 gcc_assert (expr1
->rank
== expr2
->rank
);
10235 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
10239 gcc_assert (!remap
->u
.ar
.end
[dim
]);
10240 gfc_init_se (&lbound_se
, NULL
);
10241 if (remap
->u
.ar
.start
[dim
])
10243 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
10244 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
10247 /* This remap arises from a target that is not a whole
10248 array. The start expressions will be NULL but we need
10249 the lbounds to be one. */
10250 lbound_se
.expr
= gfc_index_one_node
;
10251 gfc_conv_shift_descriptor_lbound (&block
, desc
,
10252 dim
, lbound_se
.expr
);
10253 gfc_add_block_to_block (&block
, &lbound_se
.post
);
10258 /* If rank remapping was done, check with -fcheck=bounds that
10259 the target is at least as large as the pointer. */
10260 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
10266 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
10267 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
10269 lsize
= gfc_evaluate_now (lsize
, &block
);
10270 rsize
= gfc_evaluate_now (rsize
, &block
);
10271 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
10274 msg
= _("Target of rank remapping is too small (%ld < %ld)");
10275 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
10276 msg
, rsize
, lsize
);
10279 /* Check string lengths if applicable. The check is only really added
10280 to the output code if -fbounds-check is enabled. */
10281 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
10283 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
10284 gcc_assert (strlen_lhs
&& strlen_rhs
);
10285 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
10286 strlen_lhs
, strlen_rhs
, &block
);
10289 gfc_add_block_to_block (&block
, &lse
.post
);
10291 gfc_add_block_to_block (&block
, &rse
.post
);
10294 return gfc_finish_block (&block
);
10298 /* Makes sure se is suitable for passing as a function string parameter. */
10299 /* TODO: Need to check all callers of this function. It may be abused. */
10302 gfc_conv_string_parameter (gfc_se
* se
)
10306 if (TREE_CODE (se
->expr
) == STRING_CST
)
10308 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
10309 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
10313 if ((TREE_CODE (TREE_TYPE (se
->expr
)) == ARRAY_TYPE
10314 || TREE_CODE (TREE_TYPE (se
->expr
)) == INTEGER_TYPE
)
10315 && TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
10317 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
10319 type
= TREE_TYPE (se
->expr
);
10320 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
10324 type
= gfc_get_character_type_len (gfc_default_character_kind
,
10325 se
->string_length
);
10326 type
= build_pointer_type (type
);
10327 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
10331 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
10335 /* Generate code for assignment of scalar variables. Includes character
10336 strings and derived types with allocatable components.
10337 If you know that the LHS has no allocations, set dealloc to false.
10339 DEEP_COPY has no effect if the typespec TS is not a derived type with
10340 allocatable components. Otherwise, if it is set, an explicit copy of each
10341 allocatable component is made. This is necessary as a simple copy of the
10342 whole object would copy array descriptors as is, so that the lhs's
10343 allocatable components would point to the rhs's after the assignment.
10344 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
10345 necessary if the rhs is a non-pointer function, as the allocatable components
10346 are not accessible by other means than the function's result after the
10347 function has returned. It is even more subtle when temporaries are involved,
10348 as the two following examples show:
10349 1. When we evaluate an array constructor, a temporary is created. Thus
10350 there is theoretically no alias possible. However, no deep copy is
10351 made for this temporary, so that if the constructor is made of one or
10352 more variable with allocatable components, those components still point
10353 to the variable's: DEEP_COPY should be set for the assignment from the
10354 temporary to the lhs in that case.
10355 2. When assigning a scalar to an array, we evaluate the scalar value out
10356 of the loop, store it into a temporary variable, and assign from that.
10357 In that case, deep copying when assigning to the temporary would be a
10358 waste of resources; however deep copies should happen when assigning from
10359 the temporary to each array element: again DEEP_COPY should be set for
10360 the assignment from the temporary to the lhs. */
10363 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
10364 bool deep_copy
, bool dealloc
, bool in_coarray
)
10370 gfc_init_block (&block
);
10372 if (ts
.type
== BT_CHARACTER
)
10377 if (lse
->string_length
!= NULL_TREE
)
10379 gfc_conv_string_parameter (lse
);
10380 gfc_add_block_to_block (&block
, &lse
->pre
);
10381 llen
= lse
->string_length
;
10384 if (rse
->string_length
!= NULL_TREE
)
10386 gfc_conv_string_parameter (rse
);
10387 gfc_add_block_to_block (&block
, &rse
->pre
);
10388 rlen
= rse
->string_length
;
10391 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
10392 rse
->expr
, ts
.kind
);
10394 else if (gfc_bt_struct (ts
.type
)
10395 && (ts
.u
.derived
->attr
.alloc_comp
10396 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
10398 tree tmp_var
= NULL_TREE
;
10401 /* Are the rhs and the lhs the same? */
10404 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10405 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
10406 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
10407 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
10410 /* Deallocate the lhs allocated components as long as it is not
10411 the same as the rhs. This must be done following the assignment
10412 to prevent deallocating data that could be used in the rhs
10416 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
10417 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
10419 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10421 gfc_add_expr_to_block (&lse
->post
, tmp
);
10424 gfc_add_block_to_block (&block
, &rse
->pre
);
10425 gfc_add_block_to_block (&block
, &lse
->pre
);
10427 gfc_add_modify (&block
, lse
->expr
,
10428 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
10430 /* Restore pointer address of coarray components. */
10431 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
10433 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
10434 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10436 gfc_add_expr_to_block (&block
, tmp
);
10439 /* Do a deep copy if the rhs is a variable, if it is not the
10440 same as the lhs. */
10443 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10444 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
10445 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
10447 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
10449 gfc_add_expr_to_block (&block
, tmp
);
10452 else if (gfc_bt_struct (ts
.type
))
10454 gfc_add_block_to_block (&block
, &lse
->pre
);
10455 gfc_add_block_to_block (&block
, &rse
->pre
);
10456 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
10457 TREE_TYPE (lse
->expr
), rse
->expr
);
10458 gfc_add_modify (&block
, lse
->expr
, tmp
);
10460 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10461 else if (ts
.type
== BT_CLASS
)
10463 gfc_add_block_to_block (&block
, &lse
->pre
);
10464 gfc_add_block_to_block (&block
, &rse
->pre
);
10466 if (!trans_scalar_class_assign (&block
, lse
, rse
))
10468 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10469 for the lhs which ensures that class data rhs cast as a string assigns
10471 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
10472 TREE_TYPE (rse
->expr
), lse
->expr
);
10473 gfc_add_modify (&block
, tmp
, rse
->expr
);
10476 else if (ts
.type
!= BT_CLASS
)
10478 gfc_add_block_to_block (&block
, &lse
->pre
);
10479 gfc_add_block_to_block (&block
, &rse
->pre
);
10481 gfc_add_modify (&block
, lse
->expr
,
10482 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
10485 gfc_add_block_to_block (&block
, &lse
->post
);
10486 gfc_add_block_to_block (&block
, &rse
->post
);
10488 return gfc_finish_block (&block
);
10492 /* There are quite a lot of restrictions on the optimisation in using an
10493 array function assign without a temporary. */
10496 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
10499 bool seen_array_ref
;
10501 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
10503 /* Play it safe with class functions assigned to a derived type. */
10504 if (gfc_is_class_array_function (expr2
)
10505 && expr1
->ts
.type
== BT_DERIVED
)
10508 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10509 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
10512 /* Elemental functions are scalarized so that they don't need a
10513 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10514 they would need special treatment in gfc_trans_arrayfunc_assign. */
10515 if (expr2
->value
.function
.esym
!= NULL
10516 && expr2
->value
.function
.esym
->attr
.elemental
)
10519 /* Need a temporary if rhs is not FULL or a contiguous section. */
10520 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
10523 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10524 if (gfc_ref_needs_temporary_p (expr1
->ref
))
10527 /* Functions returning pointers or allocatables need temporaries. */
10528 if (gfc_expr_attr (expr2
).pointer
10529 || gfc_expr_attr (expr2
).allocatable
)
10532 /* Character array functions need temporaries unless the
10533 character lengths are the same. */
10534 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
10536 if (expr1
->ts
.u
.cl
->length
== NULL
10537 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10540 if (expr2
->ts
.u
.cl
->length
== NULL
10541 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
10544 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
10545 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
10549 /* Check that no LHS component references appear during an array
10550 reference. This is needed because we do not have the means to
10551 span any arbitrary stride with an array descriptor. This check
10552 is not needed for the rhs because the function result has to be
10553 a complete type. */
10554 seen_array_ref
= false;
10555 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
10557 if (ref
->type
== REF_ARRAY
)
10558 seen_array_ref
= true;
10559 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
10563 /* Check for a dependency. */
10564 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
10565 expr2
->value
.function
.esym
,
10566 expr2
->value
.function
.actual
,
10570 /* If we have reached here with an intrinsic function, we do not
10571 need a temporary except in the particular case that reallocation
10572 on assignment is active and the lhs is allocatable and a target,
10573 or a pointer which may be a subref pointer. FIXME: The last
10574 condition can go away when we use span in the intrinsics
10576 if (expr2
->value
.function
.isym
)
10577 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
)
10578 || (sym
->attr
.pointer
&& sym
->attr
.subref_array_pointer
);
10580 /* If the LHS is a dummy, we need a temporary if it is not
10582 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
10585 /* If the lhs has been host_associated, is in common, a pointer or is
10586 a target and the function is not using a RESULT variable, aliasing
10587 can occur and a temporary is needed. */
10588 if ((sym
->attr
.host_assoc
10589 || sym
->attr
.in_common
10590 || sym
->attr
.pointer
10591 || sym
->attr
.cray_pointee
10592 || sym
->attr
.target
)
10593 && expr2
->symtree
!= NULL
10594 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
10597 /* A PURE function can unconditionally be called without a temporary. */
10598 if (expr2
->value
.function
.esym
!= NULL
10599 && expr2
->value
.function
.esym
->attr
.pure
)
10602 /* Implicit_pure functions are those which could legally be declared
10604 if (expr2
->value
.function
.esym
!= NULL
10605 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
10608 if (!sym
->attr
.use_assoc
10609 && !sym
->attr
.in_common
10610 && !sym
->attr
.pointer
10611 && !sym
->attr
.target
10612 && !sym
->attr
.cray_pointee
10613 && expr2
->value
.function
.esym
)
10615 /* A temporary is not needed if the function is not contained and
10616 the variable is local or host associated and not a pointer or
10618 if (!expr2
->value
.function
.esym
->attr
.contained
)
10621 /* A temporary is not needed if the lhs has never been host
10622 associated and the procedure is contained. */
10623 else if (!sym
->attr
.host_assoc
)
10626 /* A temporary is not needed if the variable is local and not
10627 a pointer, a target or a result. */
10628 if (sym
->ns
->parent
10629 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
10633 /* Default to temporary use. */
10638 /* Provide the loop info so that the lhs descriptor can be built for
10639 reallocatable assignments from extrinsic function calls. */
10642 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
10643 gfc_loopinfo
*loop
)
10645 /* Signal that the function call should not be made by
10646 gfc_conv_loop_setup. */
10647 se
->ss
->is_alloc_lhs
= 1;
10648 gfc_init_loopinfo (loop
);
10649 gfc_add_ss_to_loop (loop
, *ss
);
10650 gfc_add_ss_to_loop (loop
, se
->ss
);
10651 gfc_conv_ss_startstride (loop
);
10652 gfc_conv_loop_setup (loop
, where
);
10653 gfc_copy_loopinfo_to_se (se
, loop
);
10654 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
10655 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
10656 se
->ss
->is_alloc_lhs
= 0;
10660 /* For assignment to a reallocatable lhs from intrinsic functions,
10661 replace the se.expr (ie. the result) with a temporary descriptor.
10662 Null the data field so that the library allocates space for the
10663 result. Free the data of the original descriptor after the function,
10664 in case it appears in an argument expression and transfer the
10665 result to the original descriptor. */
10668 fcncall_realloc_result (gfc_se
*se
, int rank
)
10675 tree not_same_shape
;
10676 stmtblock_t shape_block
;
10679 /* Use the allocation done by the library. Substitute the lhs
10680 descriptor with a copy, whose data field is nulled.*/
10681 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
10682 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
10683 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
10685 /* Unallocated, the descriptor does not have a dtype. */
10686 tmp
= gfc_conv_descriptor_dtype (desc
);
10687 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
10689 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
10690 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
10691 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
10693 /* Free the lhs after the function call and copy the result data to
10694 the lhs descriptor. */
10695 tmp
= gfc_conv_descriptor_data_get (desc
);
10696 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
10697 logical_type_node
, tmp
,
10698 build_int_cst (TREE_TYPE (tmp
), 0));
10699 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
10700 tmp
= gfc_call_free (tmp
);
10701 gfc_add_expr_to_block (&se
->post
, tmp
);
10703 tmp
= gfc_conv_descriptor_data_get (res_desc
);
10704 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
10706 /* Check that the shapes are the same between lhs and expression.
10707 The evaluation of the shape is done in 'shape_block' to avoid
10708 unitialized warnings from the lhs bounds. */
10709 not_same_shape
= boolean_false_node
;
10710 gfc_start_block (&shape_block
);
10711 for (n
= 0 ; n
< rank
; n
++)
10714 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10715 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
10716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10717 gfc_array_index_type
, tmp
, tmp1
);
10718 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
10719 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
10720 gfc_array_index_type
, tmp
, tmp1
);
10721 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10722 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10723 gfc_array_index_type
, tmp
, tmp1
);
10724 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
10725 logical_type_node
, tmp
,
10726 gfc_index_zero_node
);
10727 tmp
= gfc_evaluate_now (tmp
, &shape_block
);
10729 not_same_shape
= tmp
;
10731 not_same_shape
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
10732 logical_type_node
, tmp
,
10736 /* 'zero_cond' being true is equal to lhs not being allocated or the
10737 shapes being different. */
10738 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, logical_type_node
,
10739 zero_cond
, not_same_shape
);
10740 gfc_add_modify (&shape_block
, zero_cond
, tmp
);
10741 tmp
= gfc_finish_block (&shape_block
);
10742 tmp
= build3_v (COND_EXPR
, zero_cond
,
10743 build_empty_stmt (input_location
), tmp
);
10744 gfc_add_expr_to_block (&se
->post
, tmp
);
10746 /* Now reset the bounds returned from the function call to bounds based
10747 on the lhs lbounds, except where the lhs is not allocated or the shapes
10748 of 'variable and 'expr' are different. Set the offset accordingly. */
10749 offset
= gfc_index_zero_node
;
10750 for (n
= 0 ; n
< rank
; n
++)
10754 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
10755 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
10756 gfc_array_index_type
, zero_cond
,
10757 gfc_index_one_node
, lbound
);
10758 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
10760 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
10761 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
10762 gfc_array_index_type
, tmp
, lbound
);
10763 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
10764 gfc_rank_cst
[n
], lbound
);
10765 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
10766 gfc_rank_cst
[n
], tmp
);
10768 /* Set stride and accumulate the offset. */
10769 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
10770 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
10771 gfc_rank_cst
[n
], tmp
);
10772 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
10773 gfc_array_index_type
, lbound
, tmp
);
10774 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
10775 gfc_array_index_type
, offset
, tmp
);
10776 offset
= gfc_evaluate_now (offset
, &se
->post
);
10779 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
10784 /* Try to translate array(:) = func (...), where func is a transformational
10785 array function, without using a temporary. Returns NULL if this isn't the
10789 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
10793 gfc_component
*comp
= NULL
;
10796 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
10799 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10801 comp
= gfc_get_proc_ptr_comp (expr2
);
10803 if (!(expr2
->value
.function
.isym
10804 || (comp
&& comp
->attr
.dimension
)
10805 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
10806 && expr2
->value
.function
.esym
->result
->attr
.dimension
)))
10809 gfc_init_se (&se
, NULL
);
10810 gfc_start_block (&se
.pre
);
10811 se
.want_pointer
= 1;
10813 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
10815 if (expr1
->ts
.type
== BT_DERIVED
10816 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
10819 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
10821 gfc_add_expr_to_block (&se
.pre
, tmp
);
10824 se
.direct_byref
= 1;
10825 se
.ss
= gfc_walk_expr (expr2
);
10826 gcc_assert (se
.ss
!= gfc_ss_terminator
);
10828 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10829 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10830 Clearly, this cannot be done for an allocatable function result, since
10831 the shape of the result is unknown and, in any case, the function must
10832 correctly take care of the reallocation internally. For intrinsic
10833 calls, the array data is freed and the library takes care of allocation.
10834 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10836 if (flag_realloc_lhs
10837 && gfc_is_reallocatable_lhs (expr1
)
10838 && !gfc_expr_attr (expr1
).codimension
10839 && !gfc_is_coindexed (expr1
)
10840 && !(expr2
->value
.function
.esym
10841 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
10843 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10845 if (!expr2
->value
.function
.isym
)
10847 ss
= gfc_walk_expr (expr1
);
10848 gcc_assert (ss
!= gfc_ss_terminator
);
10850 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
10851 ss
->is_alloc_lhs
= 1;
10854 fcncall_realloc_result (&se
, expr1
->rank
);
10857 gfc_conv_function_expr (&se
, expr2
);
10858 gfc_add_block_to_block (&se
.pre
, &se
.post
);
10861 gfc_cleanup_loop (&loop
);
10863 gfc_free_ss_chain (se
.ss
);
10865 return gfc_finish_block (&se
.pre
);
10869 /* Try to efficiently translate array(:) = 0. Return NULL if this
10873 gfc_trans_zero_assign (gfc_expr
* expr
)
10875 tree dest
, len
, type
;
10879 sym
= expr
->symtree
->n
.sym
;
10880 dest
= gfc_get_symbol_decl (sym
);
10882 type
= TREE_TYPE (dest
);
10883 if (POINTER_TYPE_P (type
))
10884 type
= TREE_TYPE (type
);
10885 if (!GFC_ARRAY_TYPE_P (type
))
10888 /* Determine the length of the array. */
10889 len
= GFC_TYPE_ARRAY_SIZE (type
);
10890 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
10893 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
10894 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
10895 fold_convert (gfc_array_index_type
, tmp
));
10897 /* If we are zeroing a local array avoid taking its address by emitting
10899 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
10900 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
10901 dest
, build_constructor (TREE_TYPE (dest
),
10904 /* Convert arguments to the correct types. */
10905 dest
= fold_convert (pvoid_type_node
, dest
);
10906 len
= fold_convert (size_type_node
, len
);
10908 /* Construct call to __builtin_memset. */
10909 tmp
= build_call_expr_loc (input_location
,
10910 builtin_decl_explicit (BUILT_IN_MEMSET
),
10911 3, dest
, integer_zero_node
, len
);
10912 return fold_convert (void_type_node
, tmp
);
10916 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10917 that constructs the call to __builtin_memcpy. */
10920 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
10924 /* Convert arguments to the correct types. */
10925 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
10926 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
10928 dst
= fold_convert (pvoid_type_node
, dst
);
10930 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
10931 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
10933 src
= fold_convert (pvoid_type_node
, src
);
10935 len
= fold_convert (size_type_node
, len
);
10937 /* Construct call to __builtin_memcpy. */
10938 tmp
= build_call_expr_loc (input_location
,
10939 builtin_decl_explicit (BUILT_IN_MEMCPY
),
10941 return fold_convert (void_type_node
, tmp
);
10945 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10946 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10947 source/rhs, both are gfc_full_array_ref_p which have been checked for
10951 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
10953 tree dst
, dlen
, dtype
;
10954 tree src
, slen
, stype
;
10957 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
10958 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
10960 dtype
= TREE_TYPE (dst
);
10961 if (POINTER_TYPE_P (dtype
))
10962 dtype
= TREE_TYPE (dtype
);
10963 stype
= TREE_TYPE (src
);
10964 if (POINTER_TYPE_P (stype
))
10965 stype
= TREE_TYPE (stype
);
10967 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
10970 /* Determine the lengths of the arrays. */
10971 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
10972 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
10974 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
10975 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10976 dlen
, fold_convert (gfc_array_index_type
, tmp
));
10978 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
10979 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
10981 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
10982 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
10983 slen
, fold_convert (gfc_array_index_type
, tmp
));
10985 /* Sanity check that they are the same. This should always be
10986 the case, as we should already have checked for conformance. */
10987 if (!tree_int_cst_equal (slen
, dlen
))
10990 return gfc_build_memcpy_call (dst
, src
, dlen
);
10994 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10995 this can't be done. EXPR1 is the destination/lhs for which
10996 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10999 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
11001 unsigned HOST_WIDE_INT nelem
;
11007 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
11011 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
11012 dtype
= TREE_TYPE (dst
);
11013 if (POINTER_TYPE_P (dtype
))
11014 dtype
= TREE_TYPE (dtype
);
11015 if (!GFC_ARRAY_TYPE_P (dtype
))
11018 /* Determine the lengths of the array. */
11019 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
11020 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
11023 /* Confirm that the constructor is the same size. */
11024 if (compare_tree_int (len
, nelem
) != 0)
11027 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
11028 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
11029 fold_convert (gfc_array_index_type
, tmp
));
11031 stype
= gfc_typenode_for_spec (&expr2
->ts
);
11032 src
= gfc_build_constant_array_constructor (expr2
, stype
);
11034 return gfc_build_memcpy_call (dst
, src
, len
);
11038 /* Tells whether the expression is to be treated as a variable reference. */
11041 gfc_expr_is_variable (gfc_expr
*expr
)
11044 gfc_component
*comp
;
11045 gfc_symbol
*func_ifc
;
11047 if (expr
->expr_type
== EXPR_VARIABLE
)
11050 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
11053 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
11054 return gfc_expr_is_variable (arg
);
11057 /* A data-pointer-returning function should be considered as a variable
11059 if (expr
->expr_type
== EXPR_FUNCTION
11060 && expr
->ref
== NULL
)
11062 if (expr
->value
.function
.isym
!= NULL
)
11065 if (expr
->value
.function
.esym
!= NULL
)
11067 func_ifc
= expr
->value
.function
.esym
;
11070 gcc_assert (expr
->symtree
);
11071 func_ifc
= expr
->symtree
->n
.sym
;
11075 comp
= gfc_get_proc_ptr_comp (expr
);
11076 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
11079 func_ifc
= comp
->ts
.interface
;
11083 if (expr
->expr_type
== EXPR_COMPCALL
)
11085 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
11086 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
11093 gcc_assert (func_ifc
->attr
.function
11094 && func_ifc
->result
!= NULL
);
11095 return func_ifc
->result
->attr
.pointer
;
11099 /* Is the lhs OK for automatic reallocation? */
11102 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
11106 /* An allocatable variable with no reference. */
11107 if (expr
->symtree
->n
.sym
->attr
.allocatable
11111 /* All that can be left are allocatable components. However, we do
11112 not check for allocatable components here because the expression
11113 could be an allocatable component of a pointer component. */
11114 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
11115 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
11118 /* Find an allocatable component ref last. */
11119 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
11120 if (ref
->type
== REF_COMPONENT
11122 && ref
->u
.c
.component
->attr
.allocatable
)
11129 /* Allocate or reallocate scalar lhs, as necessary. */
11132 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
11133 tree string_length
,
11141 tree size_in_bytes
;
11147 if (!expr1
|| expr1
->rank
)
11150 if (!expr2
|| expr2
->rank
)
11153 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
11154 if (ref
->type
== REF_SUBSTRING
)
11157 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
11159 /* Since this is a scalar lhs, we can afford to do this. That is,
11160 there is no risk of side effects being repeated. */
11161 gfc_init_se (&lse
, NULL
);
11162 lse
.want_pointer
= 1;
11163 gfc_conv_expr (&lse
, expr1
);
11165 jump_label1
= gfc_build_label_decl (NULL_TREE
);
11166 jump_label2
= gfc_build_label_decl (NULL_TREE
);
11168 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
11169 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
11170 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
11172 tmp
= build3_v (COND_EXPR
, cond
,
11173 build1_v (GOTO_EXPR
, jump_label1
),
11174 build_empty_stmt (input_location
));
11175 gfc_add_expr_to_block (block
, tmp
);
11177 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11179 /* Use the rhs string length and the lhs element size. */
11180 size
= string_length
;
11181 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
11182 tmp
= TYPE_SIZE_UNIT (tmp
);
11183 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
11184 TREE_TYPE (tmp
), tmp
,
11185 fold_convert (TREE_TYPE (tmp
), size
));
11189 /* Otherwise use the length in bytes of the rhs. */
11190 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
11191 size_in_bytes
= size
;
11194 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
11195 size_in_bytes
, size_one_node
);
11197 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
11199 tree caf_decl
, token
;
11201 symbol_attribute attr
;
11203 gfc_clear_attr (&attr
);
11204 gfc_init_se (&caf_se
, NULL
);
11206 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
11207 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
11209 gfc_add_block_to_block (block
, &caf_se
.pre
);
11210 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
11211 gfc_build_addr_expr (NULL_TREE
, token
),
11212 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
11215 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
11217 tmp
= build_call_expr_loc (input_location
,
11218 builtin_decl_explicit (BUILT_IN_CALLOC
),
11219 2, build_one_cst (size_type_node
),
11221 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11222 gfc_add_modify (block
, lse
.expr
, tmp
);
11226 tmp
= build_call_expr_loc (input_location
,
11227 builtin_decl_explicit (BUILT_IN_MALLOC
),
11229 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11230 gfc_add_modify (block
, lse
.expr
, tmp
);
11233 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11235 /* Deferred characters need checking for lhs and rhs string
11236 length. Other deferred parameter variables will have to
11238 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
11239 gfc_add_expr_to_block (block
, tmp
);
11241 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
11242 gfc_add_expr_to_block (block
, tmp
);
11244 /* For a deferred length character, reallocate if lengths of lhs and
11245 rhs are different. */
11246 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
11248 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
11250 fold_convert (TREE_TYPE (lse
.string_length
),
11252 /* Jump past the realloc if the lengths are the same. */
11253 tmp
= build3_v (COND_EXPR
, cond
,
11254 build1_v (GOTO_EXPR
, jump_label2
),
11255 build_empty_stmt (input_location
));
11256 gfc_add_expr_to_block (block
, tmp
);
11257 tmp
= build_call_expr_loc (input_location
,
11258 builtin_decl_explicit (BUILT_IN_REALLOC
),
11259 2, fold_convert (pvoid_type_node
, lse
.expr
),
11261 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
11262 gfc_add_modify (block
, lse
.expr
, tmp
);
11263 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
11264 gfc_add_expr_to_block (block
, tmp
);
11266 /* Update the lhs character length. */
11267 size
= string_length
;
11268 gfc_add_modify (block
, lse
.string_length
,
11269 fold_convert (TREE_TYPE (lse
.string_length
), size
));
11273 /* Check for assignments of the type
11277 to make sure we do not check for reallocation unneccessarily. */
11281 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
11283 gfc_actual_arglist
*a
;
11286 switch (expr2
->expr_type
)
11288 case EXPR_VARIABLE
:
11289 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
11291 case EXPR_FUNCTION
:
11292 if (expr2
->value
.function
.esym
11293 && expr2
->value
.function
.esym
->attr
.elemental
)
11295 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
11298 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
11303 else if (expr2
->value
.function
.isym
11304 && expr2
->value
.function
.isym
->elemental
)
11306 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
11309 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
11318 switch (expr2
->value
.op
.op
)
11320 case INTRINSIC_NOT
:
11321 case INTRINSIC_UPLUS
:
11322 case INTRINSIC_UMINUS
:
11323 case INTRINSIC_PARENTHESES
:
11324 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
11326 case INTRINSIC_PLUS
:
11327 case INTRINSIC_MINUS
:
11328 case INTRINSIC_TIMES
:
11329 case INTRINSIC_DIVIDE
:
11330 case INTRINSIC_POWER
:
11331 case INTRINSIC_AND
:
11333 case INTRINSIC_EQV
:
11334 case INTRINSIC_NEQV
:
11341 case INTRINSIC_EQ_OS
:
11342 case INTRINSIC_NE_OS
:
11343 case INTRINSIC_GT_OS
:
11344 case INTRINSIC_GE_OS
:
11345 case INTRINSIC_LT_OS
:
11346 case INTRINSIC_LE_OS
:
11348 e1
= expr2
->value
.op
.op1
;
11349 e2
= expr2
->value
.op
.op2
;
11351 if (e1
->rank
== 0 && e2
->rank
> 0)
11352 return is_runtime_conformable (expr1
, e2
);
11353 else if (e1
->rank
> 0 && e2
->rank
== 0)
11354 return is_runtime_conformable (expr1
, e1
);
11355 else if (e1
->rank
> 0 && e2
->rank
> 0)
11356 return is_runtime_conformable (expr1
, e1
)
11357 && is_runtime_conformable (expr1
, e2
);
11375 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
11376 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
11377 bool class_realloc
)
11379 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
, old_vptr
;
11380 vec
<tree
, va_gc
> *args
= NULL
;
11382 /* Store the old vptr so that dynamic types can be compared for
11383 reallocation to occur or not. */
11387 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
11388 tmp
= gfc_get_class_from_expr (tmp
);
11391 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
11394 /* Generate (re)allocation of the lhs. */
11397 stmtblock_t alloc
, re_alloc
;
11398 tree class_han
, re
, size
;
11400 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
11401 old_vptr
= gfc_evaluate_now (gfc_class_vptr_get (tmp
), block
);
11403 old_vptr
= build_int_cst (TREE_TYPE (vptr
), 0);
11405 size
= gfc_vptr_size_get (vptr
);
11406 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
11407 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
11409 /* Allocate block. */
11410 gfc_init_block (&alloc
);
11411 gfc_allocate_using_malloc (&alloc
, class_han
, size
, NULL_TREE
);
11413 /* Reallocate if dynamic types are different. */
11414 gfc_init_block (&re_alloc
);
11415 re
= build_call_expr_loc (input_location
,
11416 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
11417 fold_convert (pvoid_type_node
, class_han
),
11419 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
11420 logical_type_node
, vptr
, old_vptr
);
11421 re
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
11422 tmp
, re
, build_empty_stmt (input_location
));
11423 gfc_add_expr_to_block (&re_alloc
, re
);
11425 /* Allocate if _data is NULL, reallocate otherwise. */
11426 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
11427 logical_type_node
, class_han
,
11428 build_int_cst (prvoid_type_node
, 0));
11429 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
11431 PRED_FORTRAN_FAIL_ALLOC
),
11432 gfc_finish_block (&alloc
),
11433 gfc_finish_block (&re_alloc
));
11434 gfc_add_expr_to_block (&lse
->pre
, tmp
);
11437 fcn
= gfc_vptr_copy_get (vptr
);
11439 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
11440 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
11443 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
11444 || INDIRECT_REF_P (tmp
)
11445 || (rhs
->ts
.type
== BT_DERIVED
11446 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
11447 && !rhs
->ts
.u
.derived
->attr
.pointer
11448 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
11449 || (UNLIMITED_POLY (rhs
)
11450 && !CLASS_DATA (rhs
)->attr
.pointer
11451 && !CLASS_DATA (rhs
)->attr
.allocatable
))
11452 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
11454 vec_safe_push (args
, tmp
);
11455 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
11456 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
11457 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
11458 || INDIRECT_REF_P (tmp
)
11459 || (lhs
->ts
.type
== BT_DERIVED
11460 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
11461 && !lhs
->ts
.u
.derived
->attr
.pointer
11462 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
11463 || (UNLIMITED_POLY (lhs
)
11464 && !CLASS_DATA (lhs
)->attr
.pointer
11465 && !CLASS_DATA (lhs
)->attr
.allocatable
))
11466 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
11468 vec_safe_push (args
, tmp
);
11470 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
11472 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
11475 vec_safe_push (args
, from_len
);
11476 vec_safe_push (args
, to_len
);
11477 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
11479 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
11480 logical_type_node
, from_len
,
11481 build_zero_cst (TREE_TYPE (from_len
)));
11482 return fold_build3_loc (input_location
, COND_EXPR
,
11483 void_type_node
, tmp
,
11491 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
11492 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
11493 stmtblock_t tblock
;
11494 gfc_init_block (&tblock
);
11495 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
11496 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11497 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
11498 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
11499 /* When coming from a ptr_copy lhs and rhs are swapped. */
11500 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
11501 fold_convert (TREE_TYPE (rhst
), tmp
));
11502 return gfc_finish_block (&tblock
);
11506 /* Subroutine of gfc_trans_assignment that actually scalarizes the
11507 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11508 init_flag indicates initialization expressions and dealloc that no
11509 deallocate prior assignment is needed (if in doubt, set true).
11510 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11511 routine instead of a pointer assignment. Alias resolution is only done,
11512 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11513 where it is known, that newly allocated memory on the lhs can never be
11514 an alias of the rhs. */
11517 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
11518 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
11523 gfc_ss
*lss_section
;
11530 bool scalar_to_array
;
11531 tree string_length
;
11533 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
11534 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
11535 bool is_poly_assign
;
11538 /* Assignment of the form lhs = rhs. */
11539 gfc_start_block (&block
);
11541 gfc_init_se (&lse
, NULL
);
11542 gfc_init_se (&rse
, NULL
);
11544 /* Walk the lhs. */
11545 lss
= gfc_walk_expr (expr1
);
11546 if (gfc_is_reallocatable_lhs (expr1
))
11548 lss
->no_bounds_check
= 1;
11549 if (!(expr2
->expr_type
== EXPR_FUNCTION
11550 && expr2
->value
.function
.isym
!= NULL
11551 && !(expr2
->value
.function
.isym
->elemental
11552 || expr2
->value
.function
.isym
->conversion
)))
11553 lss
->is_alloc_lhs
= 1;
11556 lss
->no_bounds_check
= expr1
->no_bounds_check
;
11560 if ((expr1
->ts
.type
== BT_DERIVED
)
11561 && (gfc_is_class_array_function (expr2
)
11562 || gfc_is_alloc_class_scalar_function (expr2
)))
11563 expr2
->must_finalize
= 1;
11565 /* Checking whether a class assignment is desired is quite complicated and
11566 needed at two locations, so do it once only before the information is
11568 lhs_attr
= gfc_expr_attr (expr1
);
11569 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
11570 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
11571 && (expr1
->ts
.type
== BT_CLASS
11572 || gfc_is_class_array_ref (expr1
, NULL
)
11573 || gfc_is_class_scalar_expr (expr1
)
11574 || gfc_is_class_array_ref (expr2
, NULL
)
11575 || gfc_is_class_scalar_expr (expr2
))
11576 && lhs_attr
.flavor
!= FL_PROCEDURE
;
11578 realloc_flag
= flag_realloc_lhs
11579 && gfc_is_reallocatable_lhs (expr1
)
11581 && !is_runtime_conformable (expr1
, expr2
);
11583 /* Only analyze the expressions for coarray properties, when in coarray-lib
11585 if (flag_coarray
== GFC_FCOARRAY_LIB
)
11587 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
11588 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
11591 if (lss
!= gfc_ss_terminator
)
11593 /* The assignment needs scalarization. */
11596 /* Find a non-scalar SS from the lhs. */
11597 while (lss_section
!= gfc_ss_terminator
11598 && lss_section
->info
->type
!= GFC_SS_SECTION
)
11599 lss_section
= lss_section
->next
;
11601 gcc_assert (lss_section
!= gfc_ss_terminator
);
11603 /* Initialize the scalarizer. */
11604 gfc_init_loopinfo (&loop
);
11606 /* Walk the rhs. */
11607 rss
= gfc_walk_expr (expr2
);
11608 if (rss
== gfc_ss_terminator
)
11609 /* The rhs is scalar. Add a ss for the expression. */
11610 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
11611 /* When doing a class assign, then the handle to the rhs needs to be a
11612 pointer to allow for polymorphism. */
11613 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
11614 rss
->info
->type
= GFC_SS_REFERENCE
;
11616 rss
->no_bounds_check
= expr2
->no_bounds_check
;
11617 /* Associate the SS with the loop. */
11618 gfc_add_ss_to_loop (&loop
, lss
);
11619 gfc_add_ss_to_loop (&loop
, rss
);
11621 /* Calculate the bounds of the scalarization. */
11622 gfc_conv_ss_startstride (&loop
);
11623 /* Enable loop reversal. */
11624 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
11625 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
11626 /* Resolve any data dependencies in the statement. */
11628 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
11629 /* Setup the scalarizing loops. */
11630 gfc_conv_loop_setup (&loop
, &expr2
->where
);
11632 /* Setup the gfc_se structures. */
11633 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11634 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11637 gfc_mark_ss_chain_used (rss
, 1);
11638 if (loop
.temp_ss
== NULL
)
11641 gfc_mark_ss_chain_used (lss
, 1);
11645 lse
.ss
= loop
.temp_ss
;
11646 gfc_mark_ss_chain_used (lss
, 3);
11647 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
11650 /* Allow the scalarizer to workshare array assignments. */
11651 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
11652 == OMPWS_WORKSHARE_FLAG
11653 && loop
.temp_ss
== NULL
)
11655 maybe_workshare
= true;
11656 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
11659 /* Start the scalarized loop body. */
11660 gfc_start_scalarized_body (&loop
, &body
);
11663 gfc_init_block (&body
);
11665 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
11667 /* Translate the expression. */
11668 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
11669 && lhs_caf_attr
.codimension
;
11670 gfc_conv_expr (&rse
, expr2
);
11672 /* Deal with the case of a scalar class function assigned to a derived type. */
11673 if (gfc_is_alloc_class_scalar_function (expr2
)
11674 && expr1
->ts
.type
== BT_DERIVED
)
11676 rse
.expr
= gfc_class_data_get (rse
.expr
);
11677 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
11680 /* Stabilize a string length for temporaries. */
11681 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
11682 && !(VAR_P (rse
.string_length
)
11683 || TREE_CODE (rse
.string_length
) == PARM_DECL
11684 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
11685 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
11686 else if (expr2
->ts
.type
== BT_CHARACTER
)
11688 if (expr1
->ts
.deferred
11689 && gfc_expr_attr (expr1
).allocatable
11690 && gfc_check_dependency (expr1
, expr2
, true))
11691 rse
.string_length
=
11692 gfc_evaluate_now_function_scope (rse
.string_length
, &rse
.pre
);
11693 string_length
= rse
.string_length
;
11696 string_length
= NULL_TREE
;
11700 gfc_conv_tmp_array_ref (&lse
);
11701 if (expr2
->ts
.type
== BT_CHARACTER
)
11702 lse
.string_length
= string_length
;
11706 gfc_conv_expr (&lse
, expr1
);
11707 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
11709 && gfc_expr_attr (expr1
).allocatable
11716 tmp
= INDIRECT_REF_P (lse
.expr
)
11717 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
11720 /* We should only get array references here. */
11721 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
11722 || TREE_CODE (tmp
) == ARRAY_REF
);
11724 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
11725 or the array itself(ARRAY_REF). */
11726 tmp
= TREE_OPERAND (tmp
, 0);
11728 /* Provide the address of the array. */
11729 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
11730 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
11732 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
11733 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
11734 msg
= _("Assignment of scalar to unallocated array");
11735 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
11736 &expr1
->where
, msg
);
11739 /* Deallocate the lhs parameterized components if required. */
11740 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
11741 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
11743 if (expr1
->ts
.type
== BT_DERIVED
11744 && expr1
->ts
.u
.derived
11745 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
11747 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
11749 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11751 else if (expr1
->ts
.type
== BT_CLASS
11752 && CLASS_DATA (expr1
)->ts
.u
.derived
11753 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
11755 tmp
= gfc_class_data_get (lse
.expr
);
11756 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
11758 gfc_add_expr_to_block (&lse
.pre
, tmp
);
11763 /* Assignments of scalar derived types with allocatable components
11764 to arrays must be done with a deep copy and the rhs temporary
11765 must have its components deallocated afterwards. */
11766 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
11767 && expr2
->ts
.u
.derived
->attr
.alloc_comp
11768 && !gfc_expr_is_variable (expr2
)
11769 && expr1
->rank
&& !expr2
->rank
);
11770 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
11772 && expr1
->ts
.u
.derived
->attr
.alloc_comp
11773 && gfc_is_alloc_class_scalar_function (expr2
));
11774 if (scalar_to_array
&& dealloc
)
11776 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
11777 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
11780 /* When assigning a character function result to a deferred-length variable,
11781 the function call must happen before the (re)allocation of the lhs -
11782 otherwise the character length of the result is not known.
11783 NOTE 1: This relies on having the exact dependence of the length type
11784 parameter available to the caller; gfortran saves it in the .mod files.
11785 NOTE 2: Vector array references generate an index temporary that must
11786 not go outside the loop. Otherwise, variables should not generate
11788 NOTE 3: The concatenation operation generates a temporary pointer,
11789 whose allocation must go to the innermost loop.
11790 NOTE 4: Elemental functions may generate a temporary, too. */
11791 if (flag_realloc_lhs
11792 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
11793 && !(lss
!= gfc_ss_terminator
11794 && rss
!= gfc_ss_terminator
11795 && ((expr2
->expr_type
== EXPR_VARIABLE
&& expr2
->rank
)
11796 || (expr2
->expr_type
== EXPR_FUNCTION
11797 && expr2
->value
.function
.esym
!= NULL
11798 && expr2
->value
.function
.esym
->attr
.elemental
)
11799 || (expr2
->expr_type
== EXPR_FUNCTION
11800 && expr2
->value
.function
.isym
!= NULL
11801 && expr2
->value
.function
.isym
->elemental
)
11802 || (expr2
->expr_type
== EXPR_OP
11803 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))))
11804 gfc_add_block_to_block (&block
, &rse
.pre
);
11806 /* Nullify the allocatable components corresponding to those of the lhs
11807 derived type, so that the finalization of the function result does not
11808 affect the lhs of the assignment. Prepend is used to ensure that the
11809 nullification occurs before the call to the finalizer. In the case of
11810 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11811 as part of the deep copy. */
11812 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
11813 && (gfc_is_class_array_function (expr2
)
11814 || gfc_is_alloc_class_scalar_function (expr2
)))
11816 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
11817 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
11818 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
11819 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
11824 if (is_poly_assign
)
11826 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
11827 use_vptr_copy
|| (lhs_attr
.allocatable
11828 && !lhs_attr
.dimension
),
11829 !realloc_flag
&& flag_realloc_lhs
11830 && !lhs_attr
.pointer
);
11831 if (expr2
->expr_type
== EXPR_FUNCTION
11832 && expr2
->ts
.type
== BT_DERIVED
11833 && expr2
->ts
.u
.derived
->attr
.alloc_comp
)
11835 tree tmp2
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
,
11836 rse
.expr
, expr2
->rank
);
11837 if (lss
== gfc_ss_terminator
)
11838 gfc_add_expr_to_block (&rse
.post
, tmp2
);
11840 gfc_add_expr_to_block (&loop
.post
, tmp2
);
11843 else if (flag_coarray
== GFC_FCOARRAY_LIB
11844 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
11845 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
11846 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
11848 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11849 allocatable component, because those need to be accessed via the
11850 caf-runtime. No need to check for coindexes here, because resolve
11851 has rewritten those already. */
11853 gfc_actual_arglist a1
, a2
;
11854 /* Clear the structures to prevent accessing garbage. */
11855 memset (&code
, '\0', sizeof (gfc_code
));
11856 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
11857 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
11862 code
.ext
.actual
= &a1
;
11863 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
11864 tmp
= gfc_conv_intrinsic_subroutine (&code
);
11866 else if (!is_poly_assign
&& expr2
->must_finalize
11867 && expr1
->ts
.type
== BT_CLASS
11868 && expr2
->ts
.type
== BT_CLASS
)
11870 /* This case comes about when the scalarizer provides array element
11871 references. Use the vptr copy function, since this does a deep
11872 copy of allocatable components, without which the finalizer call
11873 will deallocate the components. */
11874 tmp
= gfc_get_vptr_from_expr (rse
.expr
);
11875 if (tmp
!= NULL_TREE
)
11877 tree fcn
= gfc_vptr_copy_get (tmp
);
11878 if (POINTER_TYPE_P (TREE_TYPE (fcn
)))
11879 fcn
= build_fold_indirect_ref_loc (input_location
, fcn
);
11880 tmp
= build_call_expr_loc (input_location
,
11882 gfc_build_addr_expr (NULL
, rse
.expr
),
11883 gfc_build_addr_expr (NULL
, lse
.expr
));
11887 /* If nothing else works, do it the old fashioned way! */
11888 if (tmp
== NULL_TREE
)
11889 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11890 gfc_expr_is_variable (expr2
)
11892 || expr2
->expr_type
== EXPR_ARRAY
,
11893 !(l_is_temp
|| init_flag
) && dealloc
,
11894 expr1
->symtree
->n
.sym
->attr
.codimension
);
11896 /* Add the pre blocks to the body. */
11897 gfc_add_block_to_block (&body
, &rse
.pre
);
11898 gfc_add_block_to_block (&body
, &lse
.pre
);
11899 gfc_add_expr_to_block (&body
, tmp
);
11900 /* Add the post blocks to the body. */
11901 gfc_add_block_to_block (&body
, &rse
.post
);
11902 gfc_add_block_to_block (&body
, &lse
.post
);
11904 if (lss
== gfc_ss_terminator
)
11906 /* F2003: Add the code for reallocation on assignment. */
11907 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
11908 && !is_poly_assign
)
11909 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
11912 /* Use the scalar assignment as is. */
11913 gfc_add_block_to_block (&block
, &body
);
11917 gcc_assert (lse
.ss
== gfc_ss_terminator
11918 && rse
.ss
== gfc_ss_terminator
);
11922 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
11924 /* We need to copy the temporary to the actual lhs. */
11925 gfc_init_se (&lse
, NULL
);
11926 gfc_init_se (&rse
, NULL
);
11927 gfc_copy_loopinfo_to_se (&lse
, &loop
);
11928 gfc_copy_loopinfo_to_se (&rse
, &loop
);
11930 rse
.ss
= loop
.temp_ss
;
11933 gfc_conv_tmp_array_ref (&rse
);
11934 gfc_conv_expr (&lse
, expr1
);
11936 gcc_assert (lse
.ss
== gfc_ss_terminator
11937 && rse
.ss
== gfc_ss_terminator
);
11939 if (expr2
->ts
.type
== BT_CHARACTER
)
11940 rse
.string_length
= string_length
;
11942 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
11944 gfc_add_expr_to_block (&body
, tmp
);
11947 /* F2003: Allocate or reallocate lhs of allocatable array. */
11950 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
11951 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
11952 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
11953 if (tmp
!= NULL_TREE
)
11954 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
11957 if (maybe_workshare
)
11958 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
11960 /* Generate the copying loops. */
11961 gfc_trans_scalarizing_loops (&loop
, &body
);
11963 /* Wrap the whole thing up. */
11964 gfc_add_block_to_block (&block
, &loop
.pre
);
11965 gfc_add_block_to_block (&block
, &loop
.post
);
11967 gfc_cleanup_loop (&loop
);
11970 return gfc_finish_block (&block
);
11974 /* Check whether EXPR is a copyable array. */
11977 copyable_array_p (gfc_expr
* expr
)
11979 if (expr
->expr_type
!= EXPR_VARIABLE
)
11982 /* First check it's an array. */
11983 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
11986 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
11989 /* Next check that it's of a simple enough type. */
11990 switch (expr
->ts
.type
)
12002 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
12011 /* Translate an assignment. */
12014 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
12015 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
12019 /* Special case a single function returning an array. */
12020 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
12022 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
12027 /* Special case assigning an array to zero. */
12028 if (copyable_array_p (expr1
)
12029 && is_zero_initializer_p (expr2
))
12031 tmp
= gfc_trans_zero_assign (expr1
);
12036 /* Special case copying one array to another. */
12037 if (copyable_array_p (expr1
)
12038 && copyable_array_p (expr2
)
12039 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
12040 && !gfc_check_dependency (expr1
, expr2
, 0))
12042 tmp
= gfc_trans_array_copy (expr1
, expr2
);
12047 /* Special case initializing an array from a constant array constructor. */
12048 if (copyable_array_p (expr1
)
12049 && expr2
->expr_type
== EXPR_ARRAY
12050 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
12052 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
12057 if (UNLIMITED_POLY (expr1
) && expr1
->rank
)
12058 use_vptr_copy
= true;
12060 /* Fallback to the scalarizer to generate explicit loops. */
12061 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
12062 use_vptr_copy
, may_alias
);
12066 gfc_trans_init_assign (gfc_code
* code
)
12068 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
12072 gfc_trans_assign (gfc_code
* code
)
12074 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
12077 /* Generate a simple loop for internal use of the form
12078 for (var = begin; var <cond> end; var += step)
12081 gfc_simple_for_loop (stmtblock_t
*block
, tree var
, tree begin
, tree end
,
12082 enum tree_code cond
, tree step
, tree body
)
12087 gfc_add_modify (block
, var
, begin
);
12089 /* Loop: for (var = begin; var <cond> end; var += step). */
12090 tree label_loop
= gfc_build_label_decl (NULL_TREE
);
12091 tree label_cond
= gfc_build_label_decl (NULL_TREE
);
12092 TREE_USED (label_loop
) = 1;
12093 TREE_USED (label_cond
) = 1;
12095 gfc_add_expr_to_block (block
, build1_v (GOTO_EXPR
, label_cond
));
12096 gfc_add_expr_to_block (block
, build1_v (LABEL_EXPR
, label_loop
));
12099 gfc_add_expr_to_block (block
, body
);
12101 /* End of loop body. */
12102 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
12103 gfc_add_modify (block
, var
, tmp
);
12104 gfc_add_expr_to_block (block
, build1_v (LABEL_EXPR
, label_cond
));
12105 tmp
= fold_build2_loc (input_location
, cond
, boolean_type_node
, var
, end
);
12106 tmp
= build3_v (COND_EXPR
, tmp
, build1_v (GOTO_EXPR
, label_loop
),
12107 build_empty_stmt (input_location
));
12108 gfc_add_expr_to_block (block
, tmp
);