1 /* Expression translation
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (CONSTANT_CLASS_P (scalar
))
78 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
79 gfc_add_modify (&se
->pre
, tmp
, scalar
);
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
83 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
84 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
85 gfc_get_dtype (type
));
86 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
91 gfc_add_modify (&se
->post
, scalar
,
92 fold_convert (TREE_TYPE (scalar
),
93 gfc_conv_descriptor_data_get (desc
)));
98 /* Get the coarray token from the ultimate array or component ref.
99 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
102 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
104 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
105 bool is_coarray
= sym
->attr
.codimension
;
106 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
107 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
111 if (ref
->type
== REF_COMPONENT
112 && (ref
->u
.c
.component
->attr
.allocatable
113 || ref
->u
.c
.component
->attr
.pointer
)
114 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
119 if (last_caf_ref
== NULL
)
122 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
124 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
125 if (comp
== NULL_TREE
&& comp_ref
)
127 gfc_init_se (&se
, outerse
);
128 gfc_free_ref_list (last_caf_ref
->next
);
129 last_caf_ref
->next
= NULL
;
130 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
131 se
.want_pointer
= comp_ref
;
132 gfc_conv_expr (&se
, caf_expr
);
133 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
135 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
136 se
.expr
= TREE_OPERAND (se
.expr
, 0);
137 gfc_free_expr (caf_expr
);
140 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
141 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
143 caf
= gfc_conv_descriptor_token (se
.expr
);
144 return gfc_build_addr_expr (NULL_TREE
, caf
);
148 /* This is the seed for an eventual trans-class.c
150 The following parameters should not be used directly since they might
151 in future implementations. Use the corresponding APIs. */
152 #define CLASS_DATA_FIELD 0
153 #define CLASS_VPTR_FIELD 1
154 #define CLASS_LEN_FIELD 2
155 #define VTABLE_HASH_FIELD 0
156 #define VTABLE_SIZE_FIELD 1
157 #define VTABLE_EXTENDS_FIELD 2
158 #define VTABLE_DEF_INIT_FIELD 3
159 #define VTABLE_COPY_FIELD 4
160 #define VTABLE_FINAL_FIELD 5
164 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
168 vec
<constructor_elt
, va_gc
> *init
= NULL
;
170 field
= TYPE_FIELDS (TREE_TYPE (decl
));
171 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
172 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
174 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
175 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
177 return build_constructor (TREE_TYPE (decl
), init
);
182 gfc_class_data_get (tree decl
)
185 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
186 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
187 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
189 return fold_build3_loc (input_location
, COMPONENT_REF
,
190 TREE_TYPE (data
), decl
, data
,
196 gfc_class_vptr_get (tree decl
)
199 /* For class arrays decl may be a temporary descriptor handle, the vptr is
200 then available through the saved descriptor. */
201 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
202 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
203 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
204 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
205 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
206 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
208 return fold_build3_loc (input_location
, COMPONENT_REF
,
209 TREE_TYPE (vptr
), decl
, vptr
,
215 gfc_class_len_get (tree decl
)
218 /* For class arrays decl may be a temporary descriptor handle, the len is
219 then available through the saved descriptor. */
220 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
221 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
222 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
223 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
224 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
225 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
227 return fold_build3_loc (input_location
, COMPONENT_REF
,
228 TREE_TYPE (len
), decl
, len
,
233 /* Try to get the _len component of a class. When the class is not unlimited
234 poly, i.e. no _len field exists, then return a zero node. */
237 gfc_class_len_or_zero_get (tree decl
)
240 /* For class arrays decl may be a temporary descriptor handle, the vptr is
241 then available through the saved descriptor. */
242 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
243 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
244 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
245 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
246 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
247 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
249 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
250 TREE_TYPE (len
), decl
, len
,
256 /* Get the specified FIELD from the VPTR. */
259 vptr_field_get (tree vptr
, int fieldno
)
262 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
263 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
265 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
266 TREE_TYPE (field
), vptr
, field
,
273 /* Get the field from the class' vptr. */
276 class_vtab_field_get (tree decl
, int fieldno
)
279 vptr
= gfc_class_vptr_get (decl
);
280 return vptr_field_get (vptr
, fieldno
);
284 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
286 #define VTAB_GET_FIELD_GEN(name, field) tree \
287 gfc_class_vtab_## name ##_get (tree cl) \
289 return class_vtab_field_get (cl, field); \
293 gfc_vptr_## name ##_get (tree vptr) \
295 return vptr_field_get (vptr, field); \
298 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
299 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
300 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
301 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
302 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
305 /* The size field is returned as an array index type. Therefore treat
306 it and only it specially. */
309 gfc_class_vtab_size_get (tree cl
)
312 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
313 /* Always return size as an array index type. */
314 size
= fold_convert (gfc_array_index_type
, size
);
320 gfc_vptr_size_get (tree vptr
)
323 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
324 /* Always return size as an array index type. */
325 size
= fold_convert (gfc_array_index_type
, size
);
331 #undef CLASS_DATA_FIELD
332 #undef CLASS_VPTR_FIELD
333 #undef CLASS_LEN_FIELD
334 #undef VTABLE_HASH_FIELD
335 #undef VTABLE_SIZE_FIELD
336 #undef VTABLE_EXTENDS_FIELD
337 #undef VTABLE_DEF_INIT_FIELD
338 #undef VTABLE_COPY_FIELD
339 #undef VTABLE_FINAL_FIELD
342 /* Search for the last _class ref in the chain of references of this
343 expression and cut the chain there. Albeit this routine is similiar
344 to class.c::gfc_add_component_ref (), is there a significant
345 difference: gfc_add_component_ref () concentrates on an array ref to
346 be the last ref in the chain. This routine is oblivious to the kind
347 of refs following. */
350 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
353 gfc_ref
*ref
, *class_ref
, *tail
, *array_ref
;
355 /* Find the last class reference. */
358 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
360 if (ref
->type
== REF_ARRAY
361 && ref
->u
.ar
.type
!= AR_ELEMENT
)
364 if (ref
->type
== REF_COMPONENT
365 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
367 /* Component to the right of a part reference with nonzero rank
368 must not have the ALLOCATABLE attribute. If attempts are
369 made to reference such a component reference, an error results
370 followed by anICE. */
372 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
377 if (ref
->next
== NULL
)
381 /* Remove and store all subsequent references after the
385 tail
= class_ref
->next
;
386 class_ref
->next
= NULL
;
394 base_expr
= gfc_expr_to_initialize (e
);
396 /* Restore the original tail expression. */
399 gfc_free_ref_list (class_ref
->next
);
400 class_ref
->next
= tail
;
404 gfc_free_ref_list (e
->ref
);
411 /* Reset the vptr to the declared type, e.g. after deallocation. */
414 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
421 /* Evaluate the expression and obtain the vptr from it. */
422 gfc_init_se (&se
, NULL
);
424 gfc_conv_expr_descriptor (&se
, e
);
426 gfc_conv_expr (&se
, e
);
427 gfc_add_block_to_block (block
, &se
.pre
);
428 vptr
= gfc_get_vptr_from_expr (se
.expr
);
430 /* If a vptr is not found, we can do nothing more. */
431 if (vptr
== NULL_TREE
)
434 if (UNLIMITED_POLY (e
))
435 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
438 /* Return the vptr to the address of the declared type. */
439 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
440 vtable
= vtab
->backend_decl
;
441 if (vtable
== NULL_TREE
)
442 vtable
= gfc_get_symbol_decl (vtab
);
443 vtable
= gfc_build_addr_expr (NULL
, vtable
);
444 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
445 gfc_add_modify (block
, vptr
, vtable
);
450 /* Reset the len for unlimited polymorphic objects. */
453 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
457 e
= gfc_find_and_cut_at_last_class_ref (expr
);
460 gfc_add_len_component (e
);
461 gfc_init_se (&se_len
, NULL
);
462 gfc_conv_expr (&se_len
, e
);
463 gfc_add_modify (block
, se_len
.expr
,
464 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
469 /* Obtain the vptr of the last class reference in an expression.
470 Return NULL_TREE if no class reference is found. */
473 gfc_get_vptr_from_expr (tree expr
)
478 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
480 type
= TREE_TYPE (tmp
);
483 if (GFC_CLASS_TYPE_P (type
))
484 return gfc_class_vptr_get (tmp
);
485 if (type
!= TYPE_CANONICAL (type
))
486 type
= TYPE_CANONICAL (type
);
490 if (TREE_CODE (tmp
) == VAR_DECL
491 || TREE_CODE (tmp
) == PARM_DECL
)
495 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
496 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
498 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
499 return gfc_class_vptr_get (tmp
);
506 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
509 tree tmp
, tmp2
, type
;
511 gfc_conv_descriptor_data_set (block
, lhs_desc
,
512 gfc_conv_descriptor_data_get (rhs_desc
));
513 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
514 gfc_conv_descriptor_offset_get (rhs_desc
));
516 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
517 gfc_conv_descriptor_dtype (rhs_desc
));
519 /* Assign the dimension as range-ref. */
520 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
521 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
523 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
524 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
525 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
526 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
527 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
528 gfc_add_modify (block
, tmp
, tmp2
);
532 /* Takes a derived type expression and returns the address of a temporary
533 class object of the 'declared' type. If vptr is not NULL, this is
534 used for the temporary class object.
535 optional_alloc_ptr is false when the dummy is neither allocatable
536 nor a pointer; that's only relevant for the optional handling. */
538 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
539 gfc_typespec class_ts
, tree vptr
, bool optional
,
540 bool optional_alloc_ptr
)
543 tree cond_optional
= NULL_TREE
;
549 /* The derived type needs to be converted to a temporary
551 tmp
= gfc_typenode_for_spec (&class_ts
);
552 var
= gfc_create_var (tmp
, "class");
555 ctree
= gfc_class_vptr_get (var
);
557 if (vptr
!= NULL_TREE
)
559 /* Use the dynamic vptr. */
564 /* In this case the vtab corresponds to the derived type and the
565 vptr must point to it. */
566 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
568 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
570 gfc_add_modify (&parmse
->pre
, ctree
,
571 fold_convert (TREE_TYPE (ctree
), tmp
));
573 /* Now set the data field. */
574 ctree
= gfc_class_data_get (var
);
577 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
579 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
581 /* If there is a ready made pointer to a derived type, use it
582 rather than evaluating the expression again. */
583 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
584 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
586 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
588 /* For an array reference in an elemental procedure call we need
589 to retain the ss to provide the scalarized array reference. */
590 gfc_conv_expr_reference (parmse
, e
);
591 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
593 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
595 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
596 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
600 ss
= gfc_walk_expr (e
);
601 if (ss
== gfc_ss_terminator
)
604 gfc_conv_expr_reference (parmse
, e
);
606 /* Scalar to an assumed-rank array. */
607 if (class_ts
.u
.derived
->components
->as
)
610 type
= get_scalar_to_descriptor_type (parmse
->expr
,
612 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
613 gfc_get_dtype (type
));
615 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
616 TREE_TYPE (parmse
->expr
),
617 cond_optional
, parmse
->expr
,
618 fold_convert (TREE_TYPE (parmse
->expr
),
620 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
624 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
626 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
628 fold_convert (TREE_TYPE (tmp
),
630 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
636 gfc_init_block (&block
);
639 gfc_conv_expr_descriptor (parmse
, e
);
641 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
643 gcc_assert (class_ts
.u
.derived
->components
->as
->type
645 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
649 if (gfc_expr_attr (e
).codimension
)
650 parmse
->expr
= fold_build1_loc (input_location
,
654 gfc_add_modify (&block
, ctree
, parmse
->expr
);
659 tmp
= gfc_finish_block (&block
);
661 gfc_init_block (&block
);
662 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
664 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
665 gfc_finish_block (&block
));
666 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
669 gfc_add_block_to_block (&parmse
->pre
, &block
);
673 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
674 && class_ts
.u
.derived
->components
->ts
.u
.derived
675 ->attr
.unlimited_polymorphic
)
677 /* Take care about initializing the _len component correctly. */
678 ctree
= gfc_class_len_get (var
);
679 if (UNLIMITED_POLY (e
))
684 len
= gfc_copy_expr (e
);
685 gfc_add_len_component (len
);
686 gfc_init_se (&se
, NULL
);
687 gfc_conv_expr (&se
, len
);
689 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
690 cond_optional
, se
.expr
,
691 fold_convert (TREE_TYPE (se
.expr
),
697 tmp
= integer_zero_node
;
698 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
701 /* Pass the address of the class object. */
702 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
704 if (optional
&& optional_alloc_ptr
)
705 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
706 TREE_TYPE (parmse
->expr
),
707 cond_optional
, parmse
->expr
,
708 fold_convert (TREE_TYPE (parmse
->expr
),
713 /* Create a new class container, which is required as scalar coarrays
714 have an array descriptor while normal scalars haven't. Optionally,
715 NULL pointer checks are added if the argument is OPTIONAL. */
718 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
719 gfc_typespec class_ts
, bool optional
)
721 tree var
, ctree
, tmp
;
726 gfc_init_block (&block
);
729 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
731 if (ref
->type
== REF_COMPONENT
732 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
736 if (class_ref
== NULL
737 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
738 tmp
= e
->symtree
->n
.sym
->backend_decl
;
741 /* Remove everything after the last class reference, convert the
742 expression and then recover its tailend once more. */
744 ref
= class_ref
->next
;
745 class_ref
->next
= NULL
;
746 gfc_init_se (&tmpse
, NULL
);
747 gfc_conv_expr (&tmpse
, e
);
748 class_ref
->next
= ref
;
752 var
= gfc_typenode_for_spec (&class_ts
);
753 var
= gfc_create_var (var
, "class");
755 ctree
= gfc_class_vptr_get (var
);
756 gfc_add_modify (&block
, ctree
,
757 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
759 ctree
= gfc_class_data_get (var
);
760 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
761 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
763 /* Pass the address of the class object. */
764 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
768 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
771 tmp
= gfc_finish_block (&block
);
773 gfc_init_block (&block
);
774 tmp2
= gfc_class_data_get (var
);
775 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
777 tmp2
= gfc_finish_block (&block
);
779 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
781 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
784 gfc_add_block_to_block (&parmse
->pre
, &block
);
788 /* Takes an intrinsic type expression and returns the address of a temporary
789 class object of the 'declared' type. */
791 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
792 gfc_typespec class_ts
)
800 /* The intrinsic type needs to be converted to a temporary
802 tmp
= gfc_typenode_for_spec (&class_ts
);
803 var
= gfc_create_var (tmp
, "class");
806 ctree
= gfc_class_vptr_get (var
);
808 vtab
= gfc_find_vtab (&e
->ts
);
810 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
811 gfc_add_modify (&parmse
->pre
, ctree
,
812 fold_convert (TREE_TYPE (ctree
), tmp
));
814 /* Now set the data field. */
815 ctree
= gfc_class_data_get (var
);
816 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
818 /* For an array reference in an elemental procedure call we need
819 to retain the ss to provide the scalarized array reference. */
820 gfc_conv_expr_reference (parmse
, e
);
821 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
822 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
826 ss
= gfc_walk_expr (e
);
827 if (ss
== gfc_ss_terminator
)
830 gfc_conv_expr_reference (parmse
, e
);
831 if (class_ts
.u
.derived
->components
->as
832 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
834 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
836 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
837 TREE_TYPE (ctree
), tmp
);
840 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
841 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
846 parmse
->use_offset
= 1;
847 gfc_conv_expr_descriptor (parmse
, e
);
848 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
850 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
851 TREE_TYPE (ctree
), parmse
->expr
);
852 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
855 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
859 gcc_assert (class_ts
.type
== BT_CLASS
);
860 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
861 && class_ts
.u
.derived
->components
->ts
.u
.derived
862 ->attr
.unlimited_polymorphic
)
864 ctree
= gfc_class_len_get (var
);
865 /* When the actual arg is a char array, then set the _len component of the
866 unlimited polymorphic entity, too. */
867 if (e
->ts
.type
== BT_CHARACTER
)
869 /* Start with parmse->string_length because this seems to be set to a
870 correct value more often. */
871 if (parmse
->string_length
)
872 tmp
= parmse
->string_length
;
873 /* When the string_length is not yet set, then try the backend_decl of
875 else if (e
->ts
.u
.cl
->backend_decl
)
876 tmp
= e
->ts
.u
.cl
->backend_decl
;
877 /* If both of the above approaches fail, then try to generate an
878 expression from the input, which is only feasible currently, when the
879 expression can be evaluated to a constant one. */
882 /* Try to simplify the expression. */
883 gfc_simplify_expr (e
, 0);
884 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
886 /* Amazingly all data is present to compute the length of a
887 constant string, but the expression is not yet there. */
888 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
890 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
891 e
->value
.character
.length
);
892 gfc_conv_const_charlen (e
->ts
.u
.cl
);
893 e
->ts
.u
.cl
->resolved
= 1;
894 tmp
= e
->ts
.u
.cl
->backend_decl
;
898 gfc_error ("Can't compute the length of the char array at %L.",
904 tmp
= integer_zero_node
;
906 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
908 else if (class_ts
.type
== BT_CLASS
909 && class_ts
.u
.derived
->components
910 && class_ts
.u
.derived
->components
->ts
.u
911 .derived
->attr
.unlimited_polymorphic
)
913 ctree
= gfc_class_len_get (var
);
914 gfc_add_modify (&parmse
->pre
, ctree
,
915 fold_convert (TREE_TYPE (ctree
),
918 /* Pass the address of the class object. */
919 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
923 /* Takes a scalarized class array expression and returns the
924 address of a temporary scalar class object of the 'declared'
926 OOP-TODO: This could be improved by adding code that branched on
927 the dynamic type being the same as the declared type. In this case
928 the original class expression can be passed directly.
929 optional_alloc_ptr is false when the dummy is neither allocatable
930 nor a pointer; that's relevant for the optional handling.
931 Set copyback to true if class container's _data and _vtab pointers
932 might get modified. */
935 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
936 bool elemental
, bool copyback
, bool optional
,
937 bool optional_alloc_ptr
)
943 tree cond
= NULL_TREE
;
944 tree slen
= NULL_TREE
;
948 bool full_array
= false;
950 gfc_init_block (&block
);
953 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
955 if (ref
->type
== REF_COMPONENT
956 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
959 if (ref
->next
== NULL
)
963 if ((ref
== NULL
|| class_ref
== ref
)
964 && (!class_ts
.u
.derived
->components
->as
965 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
968 /* Test for FULL_ARRAY. */
969 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
970 && gfc_expr_attr (e
).dimension
)
973 gfc_is_class_array_ref (e
, &full_array
);
975 /* The derived type needs to be converted to a temporary
977 tmp
= gfc_typenode_for_spec (&class_ts
);
978 var
= gfc_create_var (tmp
, "class");
981 ctree
= gfc_class_data_get (var
);
982 if (class_ts
.u
.derived
->components
->as
983 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
987 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
989 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
990 gfc_get_dtype (type
));
992 tmp
= gfc_class_data_get (parmse
->expr
);
993 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
994 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
996 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
999 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1003 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1004 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1005 TREE_TYPE (ctree
), parmse
->expr
);
1006 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1009 /* Return the data component, except in the case of scalarized array
1010 references, where nullification of the cannot occur and so there
1012 if (!elemental
&& full_array
&& copyback
)
1014 if (class_ts
.u
.derived
->components
->as
1015 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1018 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1019 gfc_conv_descriptor_data_get (ctree
));
1021 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1024 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1028 ctree
= gfc_class_vptr_get (var
);
1030 /* The vptr is the second field of the actual argument.
1031 First we have to find the corresponding class reference. */
1034 if (class_ref
== NULL
1035 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1037 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1038 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1039 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1040 slen
= integer_zero_node
;
1044 /* Remove everything after the last class reference, convert the
1045 expression and then recover its tailend once more. */
1047 ref
= class_ref
->next
;
1048 class_ref
->next
= NULL
;
1049 gfc_init_se (&tmpse
, NULL
);
1050 gfc_conv_expr (&tmpse
, e
);
1051 class_ref
->next
= ref
;
1053 slen
= tmpse
.string_length
;
1056 gcc_assert (tmp
!= NULL_TREE
);
1058 /* Dereference if needs be. */
1059 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1060 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1062 vptr
= gfc_class_vptr_get (tmp
);
1063 gfc_add_modify (&block
, ctree
,
1064 fold_convert (TREE_TYPE (ctree
), vptr
));
1066 /* Return the vptr component, except in the case of scalarized array
1067 references, where the dynamic type cannot change. */
1068 if (!elemental
&& full_array
&& copyback
)
1069 gfc_add_modify (&parmse
->post
, vptr
,
1070 fold_convert (TREE_TYPE (vptr
), ctree
));
1072 /* For unlimited polymorphic objects also set the _len component. */
1073 if (class_ts
.type
== BT_CLASS
1074 && class_ts
.u
.derived
->components
1075 && class_ts
.u
.derived
->components
->ts
.u
1076 .derived
->attr
.unlimited_polymorphic
)
1078 ctree
= gfc_class_len_get (var
);
1079 if (UNLIMITED_POLY (e
))
1080 tmp
= gfc_class_len_get (tmp
);
1081 else if (e
->ts
.type
== BT_CHARACTER
)
1083 gcc_assert (slen
!= NULL_TREE
);
1087 tmp
= integer_zero_node
;
1088 gfc_add_modify (&parmse
->pre
, ctree
,
1089 fold_convert (TREE_TYPE (ctree
), tmp
));
1096 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1097 /* parmse->pre may contain some preparatory instructions for the
1098 temporary array descriptor. Those may only be executed when the
1099 optional argument is set, therefore add parmse->pre's instructions
1100 to block, which is later guarded by an if (optional_arg_given). */
1101 gfc_add_block_to_block (&parmse
->pre
, &block
);
1102 block
.head
= parmse
->pre
.head
;
1103 parmse
->pre
.head
= NULL_TREE
;
1104 tmp
= gfc_finish_block (&block
);
1106 if (optional_alloc_ptr
)
1107 tmp2
= build_empty_stmt (input_location
);
1110 gfc_init_block (&block
);
1112 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1113 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1114 null_pointer_node
));
1115 tmp2
= gfc_finish_block (&block
);
1118 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1120 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1123 gfc_add_block_to_block (&parmse
->pre
, &block
);
1125 /* Pass the address of the class object. */
1126 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1128 if (optional
&& optional_alloc_ptr
)
1129 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1130 TREE_TYPE (parmse
->expr
),
1132 fold_convert (TREE_TYPE (parmse
->expr
),
1133 null_pointer_node
));
1137 /* Given a class array declaration and an index, returns the address
1138 of the referenced element. */
1141 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1143 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1144 gfc_class_data_get (class_decl
);
1145 tree size
= gfc_class_vtab_size_get (class_decl
);
1146 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1147 gfc_array_index_type
,
1150 data
= gfc_conv_descriptor_data_get (data
);
1151 ptr
= fold_convert (pvoid_type_node
, data
);
1152 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1153 return fold_convert (TREE_TYPE (data
), ptr
);
1157 /* Copies one class expression to another, assuming that if either
1158 'to' or 'from' are arrays they are packed. Should 'from' be
1159 NULL_TREE, the initialization expression for 'to' is used, assuming
1160 that the _vptr is set. */
1163 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1173 vec
<tree
, va_gc
> *args
;
1178 bool is_from_desc
= false, is_to_class
= false;
1181 /* To prevent warnings on uninitialized variables. */
1182 from_len
= to_len
= NULL_TREE
;
1184 if (from
!= NULL_TREE
)
1185 fcn
= gfc_class_vtab_copy_get (from
);
1187 fcn
= gfc_class_vtab_copy_get (to
);
1189 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1191 if (from
!= NULL_TREE
)
1193 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1197 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1201 /* Check that from is a class. When the class is part of a coarray,
1202 then from is a common pointer and is to be used as is. */
1203 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1204 ? build_fold_indirect_ref (from
) : from
;
1206 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1207 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1208 ? gfc_class_data_get (from
) : from
;
1209 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1213 from_data
= gfc_class_vtab_def_init_get (to
);
1217 if (from
!= NULL_TREE
&& unlimited
)
1218 from_len
= gfc_class_len_or_zero_get (from
);
1220 from_len
= integer_zero_node
;
1223 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1226 to_data
= gfc_class_data_get (to
);
1228 to_len
= gfc_class_len_get (to
);
1231 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1234 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1236 stmtblock_t loopbody
;
1241 gfc_init_block (&body
);
1242 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1243 gfc_array_index_type
, nelems
,
1244 gfc_index_one_node
);
1245 nelems
= gfc_evaluate_now (tmp
, &body
);
1246 index
= gfc_create_var (gfc_array_index_type
, "S");
1250 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1251 vec_safe_push (args
, from_ref
);
1254 vec_safe_push (args
, from_data
);
1257 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1260 tmp
= gfc_conv_array_data (to
);
1261 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1262 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1263 gfc_build_array_ref (tmp
, index
, to
));
1265 vec_safe_push (args
, to_ref
);
1267 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1269 /* Build the body of the loop. */
1270 gfc_init_block (&loopbody
);
1271 gfc_add_expr_to_block (&loopbody
, tmp
);
1273 /* Build the loop and return. */
1274 gfc_init_loopinfo (&loop
);
1276 loop
.from
[0] = gfc_index_zero_node
;
1277 loop
.loopvar
[0] = index
;
1278 loop
.to
[0] = nelems
;
1279 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1280 gfc_init_block (&ifbody
);
1281 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1282 stdcopy
= gfc_finish_block (&ifbody
);
1283 /* In initialization mode from_len is a constant zero. */
1284 if (unlimited
&& !integer_zerop (from_len
))
1286 vec_safe_push (args
, from_len
);
1287 vec_safe_push (args
, to_len
);
1288 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1289 /* Build the body of the loop. */
1290 gfc_init_block (&loopbody
);
1291 gfc_add_expr_to_block (&loopbody
, tmp
);
1293 /* Build the loop and return. */
1294 gfc_init_loopinfo (&loop
);
1296 loop
.from
[0] = gfc_index_zero_node
;
1297 loop
.loopvar
[0] = index
;
1298 loop
.to
[0] = nelems
;
1299 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1300 gfc_init_block (&ifbody
);
1301 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1302 extcopy
= gfc_finish_block (&ifbody
);
1304 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1305 boolean_type_node
, from_len
,
1307 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1308 void_type_node
, tmp
, extcopy
, stdcopy
);
1309 gfc_add_expr_to_block (&body
, tmp
);
1310 tmp
= gfc_finish_block (&body
);
1314 gfc_add_expr_to_block (&body
, stdcopy
);
1315 tmp
= gfc_finish_block (&body
);
1317 gfc_cleanup_loop (&loop
);
1321 gcc_assert (!is_from_desc
);
1322 vec_safe_push (args
, from_data
);
1323 vec_safe_push (args
, to_data
);
1324 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1326 /* In initialization mode from_len is a constant zero. */
1327 if (unlimited
&& !integer_zerop (from_len
))
1329 vec_safe_push (args
, from_len
);
1330 vec_safe_push (args
, to_len
);
1331 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1332 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1333 boolean_type_node
, from_len
,
1335 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1336 void_type_node
, tmp
, extcopy
, stdcopy
);
1342 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1343 if (from
== NULL_TREE
)
1346 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1348 from_data
, null_pointer_node
);
1349 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1350 void_type_node
, cond
,
1351 tmp
, build_empty_stmt (input_location
));
1359 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1361 gfc_actual_arglist
*actual
;
1366 actual
= gfc_get_actual_arglist ();
1367 actual
->expr
= gfc_copy_expr (rhs
);
1368 actual
->next
= gfc_get_actual_arglist ();
1369 actual
->next
->expr
= gfc_copy_expr (lhs
);
1370 ppc
= gfc_copy_expr (obj
);
1371 gfc_add_vptr_component (ppc
);
1372 gfc_add_component_ref (ppc
, "_copy");
1373 ppc_code
= gfc_get_code (EXEC_CALL
);
1374 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1375 /* Although '_copy' is set to be elemental in class.c, it is
1376 not staying that way. Find out why, sometime.... */
1377 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1378 ppc_code
->ext
.actual
= actual
;
1379 ppc_code
->expr1
= ppc
;
1380 /* Since '_copy' is elemental, the scalarizer will take care
1381 of arrays in gfc_trans_call. */
1382 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1383 gfc_free_statements (ppc_code
);
1385 if (UNLIMITED_POLY(obj
))
1387 /* Check if rhs is non-NULL. */
1389 gfc_init_se (&src
, NULL
);
1390 gfc_conv_expr (&src
, rhs
);
1391 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1392 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1393 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1394 null_pointer_node
));
1395 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1396 build_empty_stmt (input_location
));
1402 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1403 A MEMCPY is needed to copy the full data from the default initializer
1404 of the dynamic type. */
1407 gfc_trans_class_init_assign (gfc_code
*code
)
1411 gfc_se dst
,src
,memsz
;
1412 gfc_expr
*lhs
, *rhs
, *sz
;
1414 gfc_start_block (&block
);
1416 lhs
= gfc_copy_expr (code
->expr1
);
1417 gfc_add_data_component (lhs
);
1419 rhs
= gfc_copy_expr (code
->expr1
);
1420 gfc_add_vptr_component (rhs
);
1422 /* Make sure that the component backend_decls have been built, which
1423 will not have happened if the derived types concerned have not
1425 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1426 gfc_add_def_init_component (rhs
);
1427 /* The _def_init is always scalar. */
1430 if (code
->expr1
->ts
.type
== BT_CLASS
1431 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1432 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1435 sz
= gfc_copy_expr (code
->expr1
);
1436 gfc_add_vptr_component (sz
);
1437 gfc_add_size_component (sz
);
1439 gfc_init_se (&dst
, NULL
);
1440 gfc_init_se (&src
, NULL
);
1441 gfc_init_se (&memsz
, NULL
);
1442 gfc_conv_expr (&dst
, lhs
);
1443 gfc_conv_expr (&src
, rhs
);
1444 gfc_conv_expr (&memsz
, sz
);
1445 gfc_add_block_to_block (&block
, &src
.pre
);
1446 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1448 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1450 if (UNLIMITED_POLY(code
->expr1
))
1452 /* Check if _def_init is non-NULL. */
1453 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1454 boolean_type_node
, src
.expr
,
1455 fold_convert (TREE_TYPE (src
.expr
),
1456 null_pointer_node
));
1457 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1458 tmp
, build_empty_stmt (input_location
));
1462 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1463 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1465 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1466 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1468 build_empty_stmt (input_location
));
1471 gfc_add_expr_to_block (&block
, tmp
);
1473 return gfc_finish_block (&block
);
1477 /* Translate an assignment to a CLASS object
1478 (pointer or ordinary assignment). */
1481 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1489 gfc_start_block (&block
);
1492 while (ref
&& ref
->next
)
1495 /* Class valued proc_pointer assignments do not need any further
1497 if (ref
&& ref
->type
== REF_COMPONENT
1498 && ref
->u
.c
.component
->attr
.proc_pointer
1499 && expr2
->expr_type
== EXPR_VARIABLE
1500 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1501 && op
== EXEC_POINTER_ASSIGN
)
1504 if (expr2
->ts
.type
!= BT_CLASS
)
1506 /* Insert an additional assignment which sets the '_vptr' field. */
1507 gfc_symbol
*vtab
= NULL
;
1510 lhs
= gfc_copy_expr (expr1
);
1511 gfc_add_vptr_component (lhs
);
1513 if (UNLIMITED_POLY (expr1
)
1514 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1516 rhs
= gfc_get_null_expr (&expr2
->where
);
1520 if (expr2
->expr_type
== EXPR_NULL
)
1521 vtab
= gfc_find_vtab (&expr1
->ts
);
1523 vtab
= gfc_find_vtab (&expr2
->ts
);
1526 rhs
= gfc_get_expr ();
1527 rhs
->expr_type
= EXPR_VARIABLE
;
1528 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1532 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1533 gfc_add_expr_to_block (&block
, tmp
);
1535 gfc_free_expr (lhs
);
1536 gfc_free_expr (rhs
);
1538 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1540 /* F2003:C717 only sequence and bind-C types can come here. */
1541 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1542 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1543 gfc_add_data_component (expr2
);
1546 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1548 /* Insert an additional assignment which sets the '_vptr' field. */
1549 lhs
= gfc_copy_expr (expr1
);
1550 gfc_add_vptr_component (lhs
);
1552 rhs
= gfc_copy_expr (expr2
);
1553 gfc_add_vptr_component (rhs
);
1555 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1556 gfc_add_expr_to_block (&block
, tmp
);
1558 gfc_free_expr (lhs
);
1559 gfc_free_expr (rhs
);
1562 /* Do the actual CLASS assignment. */
1563 if (expr2
->ts
.type
== BT_CLASS
1564 && !CLASS_DATA (expr2
)->attr
.dimension
)
1566 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1567 || !CLASS_DATA (expr2
)->attr
.dimension
)
1568 gfc_add_data_component (expr1
);
1572 if (op
== EXEC_ASSIGN
)
1573 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1574 else if (op
== EXEC_POINTER_ASSIGN
)
1575 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1579 gfc_add_expr_to_block (&block
, tmp
);
1581 return gfc_finish_block (&block
);
1585 /* End of prototype trans-class.c */
1589 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1591 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1592 gfc_warning (OPT_Wrealloc_lhs
,
1593 "Code for reallocating the allocatable array at %L will "
1595 else if (warn_realloc_lhs_all
)
1596 gfc_warning (OPT_Wrealloc_lhs_all
,
1597 "Code for reallocating the allocatable variable at %L "
1598 "will be added", where
);
1602 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1605 /* Copy the scalarization loop variables. */
1608 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1611 dest
->loop
= src
->loop
;
1615 /* Initialize a simple expression holder.
1617 Care must be taken when multiple se are created with the same parent.
1618 The child se must be kept in sync. The easiest way is to delay creation
1619 of a child se until after after the previous se has been translated. */
1622 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1624 memset (se
, 0, sizeof (gfc_se
));
1625 gfc_init_block (&se
->pre
);
1626 gfc_init_block (&se
->post
);
1628 se
->parent
= parent
;
1631 gfc_copy_se_loopvars (se
, parent
);
1635 /* Advances to the next SS in the chain. Use this rather than setting
1636 se->ss = se->ss->next because all the parents needs to be kept in sync.
1640 gfc_advance_se_ss_chain (gfc_se
* se
)
1645 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1648 /* Walk down the parent chain. */
1651 /* Simple consistency check. */
1652 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1653 || p
->parent
->ss
->nested_ss
== p
->ss
);
1655 /* If we were in a nested loop, the next scalarized expression can be
1656 on the parent ss' next pointer. Thus we should not take the next
1657 pointer blindly, but rather go up one nest level as long as next
1658 is the end of chain. */
1660 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1670 /* Ensures the result of the expression as either a temporary variable
1671 or a constant so that it can be used repeatedly. */
1674 gfc_make_safe_expr (gfc_se
* se
)
1678 if (CONSTANT_CLASS_P (se
->expr
))
1681 /* We need a temporary for this result. */
1682 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1683 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1688 /* Return an expression which determines if a dummy parameter is present.
1689 Also used for arguments to procedures with multiple entry points. */
1692 gfc_conv_expr_present (gfc_symbol
* sym
)
1696 gcc_assert (sym
->attr
.dummy
);
1697 decl
= gfc_get_symbol_decl (sym
);
1699 /* Intrinsic scalars with VALUE attribute which are passed by value
1700 use a hidden argument to denote the present status. */
1701 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1702 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1703 && !sym
->attr
.dimension
)
1705 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1708 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1710 strcpy (&name
[1], sym
->name
);
1711 tree_name
= get_identifier (name
);
1713 /* Walk function argument list to find hidden arg. */
1714 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1715 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1716 if (DECL_NAME (cond
) == tree_name
)
1723 if (TREE_CODE (decl
) != PARM_DECL
)
1725 /* Array parameters use a temporary descriptor, we want the real
1727 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1728 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1729 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1732 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1733 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1735 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1736 as actual argument to denote absent dummies. For array descriptors,
1737 we thus also need to check the array descriptor. For BT_CLASS, it
1738 can also occur for scalars and F2003 due to type->class wrapping and
1739 class->class wrapping. Note further that BT_CLASS always uses an
1740 array descriptor for arrays, also for explicit-shape/assumed-size. */
1742 if (!sym
->attr
.allocatable
1743 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1744 || (sym
->ts
.type
== BT_CLASS
1745 && !CLASS_DATA (sym
)->attr
.allocatable
1746 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1747 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1748 || sym
->ts
.type
== BT_CLASS
))
1752 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1753 || sym
->as
->type
== AS_ASSUMED_RANK
1754 || sym
->attr
.codimension
))
1755 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1757 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1758 if (sym
->ts
.type
== BT_CLASS
)
1759 tmp
= gfc_class_data_get (tmp
);
1760 tmp
= gfc_conv_array_data (tmp
);
1762 else if (sym
->ts
.type
== BT_CLASS
)
1763 tmp
= gfc_class_data_get (decl
);
1767 if (tmp
!= NULL_TREE
)
1769 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1770 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1771 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1772 boolean_type_node
, cond
, tmp
);
1780 /* Converts a missing, dummy argument into a null or zero. */
1783 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1788 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1792 /* Create a temporary and convert it to the correct type. */
1793 tmp
= gfc_get_int_type (kind
);
1794 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1797 /* Test for a NULL value. */
1798 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1799 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1800 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1801 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1805 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1807 build_zero_cst (TREE_TYPE (se
->expr
)));
1808 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1812 if (ts
.type
== BT_CHARACTER
)
1814 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1815 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1816 present
, se
->string_length
, tmp
);
1817 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1818 se
->string_length
= tmp
;
1824 /* Get the character length of an expression, looking through gfc_refs
1828 gfc_get_expr_charlen (gfc_expr
*e
)
1833 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1834 && e
->ts
.type
== BT_CHARACTER
);
1836 length
= NULL
; /* To silence compiler warning. */
1838 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1841 gfc_init_se (&tmpse
, NULL
);
1842 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1843 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1847 /* First candidate: if the variable is of type CHARACTER, the
1848 expression's length could be the length of the character
1850 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1851 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1853 /* Look through the reference chain for component references. */
1854 for (r
= e
->ref
; r
; r
= r
->next
)
1859 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1860 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1868 /* We should never got substring references here. These will be
1869 broken down by the scalarizer. */
1875 gcc_assert (length
!= NULL
);
1880 /* Return for an expression the backend decl of the coarray. */
1883 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1889 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1891 /* Not-implemented diagnostic. */
1892 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1893 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1894 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1895 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1896 "%L is not supported", &expr
->where
);
1898 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1899 if (ref
->type
== REF_COMPONENT
)
1901 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1902 && UNLIMITED_POLY (ref
->u
.c
.component
)
1903 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1904 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1905 "component at %L is not supported", &expr
->where
);
1908 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1909 gcc_assert (caf_decl
);
1910 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1912 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1914 caf_decl
= gfc_class_data_get (caf_decl
);
1915 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1918 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1920 if (ref
->type
== REF_COMPONENT
1921 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1923 caf_decl
= gfc_class_data_get (caf_decl
);
1924 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1928 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1932 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1935 /* The following code assumes that the coarray is a component reachable via
1936 only scalar components/variables; the Fortran standard guarantees this. */
1938 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1939 if (ref
->type
== REF_COMPONENT
)
1941 gfc_component
*comp
= ref
->u
.c
.component
;
1943 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1944 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1945 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1946 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1947 comp
->backend_decl
, NULL_TREE
);
1948 if (comp
->ts
.type
== BT_CLASS
)
1950 caf_decl
= gfc_class_data_get (caf_decl
);
1951 if (CLASS_DATA (comp
)->attr
.codimension
)
1957 if (comp
->attr
.codimension
)
1963 gcc_assert (found
&& caf_decl
);
1968 /* Obtain the Coarray token - and optionally also the offset. */
1971 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1972 tree se_expr
, gfc_expr
*expr
)
1976 /* Coarray token. */
1977 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1979 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1980 == GFC_ARRAY_ALLOCATABLE
1981 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1982 *token
= gfc_conv_descriptor_token (caf_decl
);
1984 else if (DECL_LANG_SPECIFIC (caf_decl
)
1985 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1986 *token
= GFC_DECL_TOKEN (caf_decl
);
1989 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1990 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1991 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1997 /* Offset between the coarray base address and the address wanted. */
1998 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1999 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
2000 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
2001 *offset
= build_int_cst (gfc_array_index_type
, 0);
2002 else if (DECL_LANG_SPECIFIC (caf_decl
)
2003 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
2004 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
2005 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
2006 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
2008 *offset
= build_int_cst (gfc_array_index_type
, 0);
2010 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
2011 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
2013 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
2014 tmp
= gfc_conv_descriptor_data_get (tmp
);
2016 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
2017 tmp
= gfc_conv_descriptor_data_get (se_expr
);
2020 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
2024 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2025 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2027 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2028 && expr
->symtree
->n
.sym
->attr
.codimension
2029 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2031 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2032 gfc_ref
*ref
= base_expr
->ref
;
2035 // Iterate through the refs until the last one.
2039 if (ref
->type
== REF_ARRAY
2040 && ref
->u
.ar
.type
!= AR_FULL
)
2042 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2044 for (i
= 0; i
< ranksum
; ++i
)
2046 ref
->u
.ar
.start
[i
] = NULL
;
2047 ref
->u
.ar
.end
[i
] = NULL
;
2049 ref
->u
.ar
.type
= AR_FULL
;
2051 gfc_init_se (&base_se
, NULL
);
2052 if (gfc_caf_attr (base_expr
).dimension
)
2054 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2055 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2059 gfc_conv_expr (&base_se
, base_expr
);
2063 gfc_free_expr (base_expr
);
2064 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2065 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2067 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2068 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2071 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2075 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2076 fold_convert (gfc_array_index_type
, *offset
),
2077 fold_convert (gfc_array_index_type
, tmp
));
2081 /* Convert the coindex of a coarray into an image index; the result is
2082 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2083 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2086 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2089 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2093 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2094 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2096 gcc_assert (ref
!= NULL
);
2098 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2100 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2104 img_idx
= integer_zero_node
;
2105 extent
= integer_one_node
;
2106 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2107 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2109 gfc_init_se (&se
, NULL
);
2110 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2111 gfc_add_block_to_block (block
, &se
.pre
);
2112 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2113 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2114 integer_type_node
, se
.expr
,
2115 fold_convert(integer_type_node
, lbound
));
2116 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2118 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2120 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2122 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2123 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2124 tmp
= fold_convert (integer_type_node
, tmp
);
2125 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2126 integer_type_node
, extent
, tmp
);
2130 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2132 gfc_init_se (&se
, NULL
);
2133 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2134 gfc_add_block_to_block (block
, &se
.pre
);
2135 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2136 lbound
= fold_convert (integer_type_node
, lbound
);
2137 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2138 integer_type_node
, se
.expr
, lbound
);
2139 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2141 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2143 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2145 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2146 ubound
= fold_convert (integer_type_node
, ubound
);
2147 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2148 integer_type_node
, ubound
, lbound
);
2149 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2150 tmp
, integer_one_node
);
2151 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2152 integer_type_node
, extent
, tmp
);
2155 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2156 img_idx
, integer_one_node
);
2161 /* For each character array constructor subexpression without a ts.u.cl->length,
2162 replace it by its first element (if there aren't any elements, the length
2163 should already be set to zero). */
2166 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2168 gfc_actual_arglist
* arg
;
2174 switch (e
->expr_type
)
2178 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2179 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2183 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2187 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2188 flatten_array_ctors_without_strlen (arg
->expr
);
2193 /* We've found what we're looking for. */
2194 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2199 gcc_assert (e
->value
.constructor
);
2201 c
= gfc_constructor_first (e
->value
.constructor
);
2205 flatten_array_ctors_without_strlen (new_expr
);
2206 gfc_replace_expr (e
, new_expr
);
2210 /* Otherwise, fall through to handle constructor elements. */
2212 case EXPR_STRUCTURE
:
2213 for (c
= gfc_constructor_first (e
->value
.constructor
);
2214 c
; c
= gfc_constructor_next (c
))
2215 flatten_array_ctors_without_strlen (c
->expr
);
2225 /* Generate code to initialize a string length variable. Returns the
2226 value. For array constructors, cl->length might be NULL and in this case,
2227 the first element of the constructor is needed. expr is the original
2228 expression so we can access it but can be NULL if this is not needed. */
2231 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2235 gfc_init_se (&se
, NULL
);
2239 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2242 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2243 "flatten" array constructors by taking their first element; all elements
2244 should be the same length or a cl->length should be present. */
2247 gfc_expr
* expr_flat
;
2249 expr_flat
= gfc_copy_expr (expr
);
2250 flatten_array_ctors_without_strlen (expr_flat
);
2251 gfc_resolve_expr (expr_flat
);
2253 gfc_conv_expr (&se
, expr_flat
);
2254 gfc_add_block_to_block (pblock
, &se
.pre
);
2255 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2257 gfc_free_expr (expr_flat
);
2261 /* Convert cl->length. */
2263 gcc_assert (cl
->length
);
2265 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2266 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2267 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2268 gfc_add_block_to_block (pblock
, &se
.pre
);
2270 if (cl
->backend_decl
)
2271 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2273 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2278 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2279 const char *name
, locus
*where
)
2289 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2290 type
= build_pointer_type (type
);
2292 gfc_init_se (&start
, se
);
2293 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2294 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2296 if (integer_onep (start
.expr
))
2297 gfc_conv_string_parameter (se
);
2302 /* Avoid multiple evaluation of substring start. */
2303 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2304 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2306 /* Change the start of the string. */
2307 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2310 tmp
= build_fold_indirect_ref_loc (input_location
,
2312 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2313 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2316 /* Length = end + 1 - start. */
2317 gfc_init_se (&end
, se
);
2318 if (ref
->u
.ss
.end
== NULL
)
2319 end
.expr
= se
->string_length
;
2322 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2323 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2327 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2328 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2330 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2332 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2333 boolean_type_node
, start
.expr
,
2336 /* Check lower bound. */
2337 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2339 build_int_cst (gfc_charlen_type_node
, 1));
2340 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2341 boolean_type_node
, nonempty
, fault
);
2343 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2344 "is less than one", name
);
2346 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2347 "is less than one");
2348 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2349 fold_convert (long_integer_type_node
,
2353 /* Check upper bound. */
2354 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2355 end
.expr
, se
->string_length
);
2356 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2357 boolean_type_node
, nonempty
, fault
);
2359 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2360 "exceeds string length (%%ld)", name
);
2362 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2363 "exceeds string length (%%ld)");
2364 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2365 fold_convert (long_integer_type_node
, end
.expr
),
2366 fold_convert (long_integer_type_node
,
2367 se
->string_length
));
2371 /* Try to calculate the length from the start and end expressions. */
2373 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2377 i_len
= mpz_get_si (length
) + 1;
2381 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2382 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2386 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2387 end
.expr
, start
.expr
);
2388 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2389 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2390 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2391 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2394 se
->string_length
= tmp
;
2398 /* Convert a derived type component reference. */
2401 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2409 c
= ref
->u
.c
.component
;
2411 if (c
->backend_decl
== NULL_TREE
2412 && ref
->u
.c
.sym
!= NULL
)
2413 gfc_get_derived_type (ref
->u
.c
.sym
);
2415 field
= c
->backend_decl
;
2416 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2418 context
= DECL_FIELD_CONTEXT (field
);
2420 /* Components can correspond to fields of different containing
2421 types, as components are created without context, whereas
2422 a concrete use of a component has the type of decl as context.
2423 So, if the type doesn't match, we search the corresponding
2424 FIELD_DECL in the parent type. To not waste too much time
2425 we cache this result in norestrict_decl.
2426 On the other hand, if the context is a UNION or a MAP (a
2427 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2429 if (context
!= TREE_TYPE (decl
)
2430 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2431 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2433 tree f2
= c
->norestrict_decl
;
2434 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2435 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2436 if (TREE_CODE (f2
) == FIELD_DECL
2437 && DECL_NAME (f2
) == DECL_NAME (field
))
2440 c
->norestrict_decl
= f2
;
2444 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2445 && strcmp ("_data", c
->name
) == 0)
2447 /* Found a ref to the _data component. Store the associated ref to
2448 the vptr in se->class_vptr. */
2449 se
->class_vptr
= gfc_class_vptr_get (decl
);
2452 se
->class_vptr
= NULL_TREE
;
2454 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2455 decl
, field
, NULL_TREE
);
2459 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2460 strlen () conditional below. */
2461 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2462 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2464 tmp
= c
->ts
.u
.cl
->backend_decl
;
2465 /* Components must always be constant length. */
2466 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2467 se
->string_length
= tmp
;
2470 if (gfc_deferred_strlen (c
, &field
))
2472 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2474 decl
, field
, NULL_TREE
);
2475 se
->string_length
= tmp
;
2478 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2479 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2480 && c
->ts
.type
!= BT_CHARACTER
)
2481 || c
->attr
.proc_pointer
)
2482 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2487 /* This function deals with component references to components of the
2488 parent type for derived type extensions. */
2490 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2498 c
= ref
->u
.c
.component
;
2500 /* Return if the component is in the parent type. */
2501 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2502 if (strcmp (c
->name
, cmp
->name
) == 0)
2505 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2506 parent
.type
= REF_COMPONENT
;
2508 parent
.u
.c
.sym
= dt
;
2509 parent
.u
.c
.component
= dt
->components
;
2511 if (dt
->backend_decl
== NULL
)
2512 gfc_get_derived_type (dt
);
2514 /* Build the reference and call self. */
2515 gfc_conv_component_ref (se
, &parent
);
2516 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2517 parent
.u
.c
.component
= c
;
2518 conv_parent_component_references (se
, &parent
);
2521 /* Return the contents of a variable. Also handles reference/pointer
2522 variables (all Fortran pointer references are implicit). */
2525 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2530 tree parent_decl
= NULL_TREE
;
2533 bool alternate_entry
;
2536 bool first_time
= true;
2538 sym
= expr
->symtree
->n
.sym
;
2539 is_classarray
= IS_CLASS_ARRAY (sym
);
2543 gfc_ss_info
*ss_info
= ss
->info
;
2545 /* Check that something hasn't gone horribly wrong. */
2546 gcc_assert (ss
!= gfc_ss_terminator
);
2547 gcc_assert (ss_info
->expr
== expr
);
2549 /* A scalarized term. We already know the descriptor. */
2550 se
->expr
= ss_info
->data
.array
.descriptor
;
2551 se
->string_length
= ss_info
->string_length
;
2552 ref
= ss_info
->data
.array
.ref
;
2554 gcc_assert (ref
->type
== REF_ARRAY
2555 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2557 gfc_conv_tmp_array_ref (se
);
2561 tree se_expr
= NULL_TREE
;
2563 se
->expr
= gfc_get_symbol_decl (sym
);
2565 /* Deal with references to a parent results or entries by storing
2566 the current_function_decl and moving to the parent_decl. */
2567 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2568 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2569 && sym
->result
== sym
;
2570 entry_master
= sym
->attr
.result
2571 && sym
->ns
->proc_name
->attr
.entry_master
2572 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2573 if (current_function_decl
)
2574 parent_decl
= DECL_CONTEXT (current_function_decl
);
2576 if ((se
->expr
== parent_decl
&& return_value
)
2577 || (sym
->ns
&& sym
->ns
->proc_name
2579 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2580 && (alternate_entry
|| entry_master
)))
2585 /* Special case for assigning the return value of a function.
2586 Self recursive functions must have an explicit return value. */
2587 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2588 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2590 /* Similarly for alternate entry points. */
2591 else if (alternate_entry
2592 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2595 gfc_entry_list
*el
= NULL
;
2597 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2600 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2605 else if (entry_master
2606 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2608 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2613 /* Procedure actual arguments. */
2614 else if (sym
->attr
.flavor
== FL_PROCEDURE
2615 && se
->expr
!= current_function_decl
)
2617 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2619 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2620 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2626 /* Dereference the expression, where needed. Since characters
2627 are entirely different from other types, they are treated
2629 if (sym
->ts
.type
== BT_CHARACTER
)
2631 /* Dereference character pointer dummy arguments
2633 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2635 || sym
->attr
.function
2636 || sym
->attr
.result
))
2637 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2641 else if (!sym
->attr
.value
)
2643 /* Dereference temporaries for class array dummy arguments. */
2644 if (sym
->attr
.dummy
&& is_classarray
2645 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2647 if (!se
->descriptor_only
)
2648 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2650 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2654 /* Dereference non-character scalar dummy arguments. */
2655 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2656 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2657 && (sym
->ts
.type
!= BT_CLASS
2658 || (!CLASS_DATA (sym
)->attr
.dimension
2659 && !(CLASS_DATA (sym
)->attr
.codimension
2660 && CLASS_DATA (sym
)->attr
.allocatable
))))
2661 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2664 /* Dereference scalar hidden result. */
2665 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2666 && (sym
->attr
.function
|| sym
->attr
.result
)
2667 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2668 && !sym
->attr
.always_explicit
)
2669 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2672 /* Dereference non-character, non-class pointer variables.
2673 These must be dummies, results, or scalars. */
2675 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2676 || gfc_is_associate_pointer (sym
)
2677 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2679 || sym
->attr
.function
2681 || (!sym
->attr
.dimension
2682 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2683 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2685 /* Now treat the class array pointer variables accordingly. */
2686 else if (sym
->ts
.type
== BT_CLASS
2688 && (CLASS_DATA (sym
)->attr
.dimension
2689 || CLASS_DATA (sym
)->attr
.codimension
)
2690 && ((CLASS_DATA (sym
)->as
2691 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2692 || CLASS_DATA (sym
)->attr
.allocatable
2693 || CLASS_DATA (sym
)->attr
.class_pointer
))
2694 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2696 /* And the case where a non-dummy, non-result, non-function,
2697 non-allotable and non-pointer classarray is present. This case was
2698 previously covered by the first if, but with introducing the
2699 condition !is_classarray there, that case has to be covered
2701 else if (sym
->ts
.type
== BT_CLASS
2703 && !sym
->attr
.function
2704 && !sym
->attr
.result
2705 && (CLASS_DATA (sym
)->attr
.dimension
2706 || CLASS_DATA (sym
)->attr
.codimension
)
2708 || !CLASS_DATA (sym
)->attr
.allocatable
)
2709 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2710 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2717 /* For character variables, also get the length. */
2718 if (sym
->ts
.type
== BT_CHARACTER
)
2720 /* If the character length of an entry isn't set, get the length from
2721 the master function instead. */
2722 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2723 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2725 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2726 gcc_assert (se
->string_length
);
2734 /* Return the descriptor if that's what we want and this is an array
2735 section reference. */
2736 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2738 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2739 /* Return the descriptor for array pointers and allocations. */
2740 if (se
->want_pointer
2741 && ref
->next
== NULL
&& (se
->descriptor_only
))
2744 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2745 /* Return a pointer to an element. */
2749 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2750 && se
->descriptor_only
2751 && !CLASS_DATA (sym
)->attr
.allocatable
2752 && !CLASS_DATA (sym
)->attr
.class_pointer
2753 && CLASS_DATA (sym
)->as
2754 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2755 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2756 /* Skip the first ref of a _data component, because for class
2757 arrays that one is already done by introducing a temporary
2758 array descriptor. */
2761 if (ref
->u
.c
.sym
->attr
.extension
)
2762 conv_parent_component_references (se
, ref
);
2764 gfc_conv_component_ref (se
, ref
);
2765 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2766 && se
->want_pointer
&& se
->descriptor_only
)
2772 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2773 expr
->symtree
->name
, &expr
->where
);
2783 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2785 if (se
->want_pointer
)
2787 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2788 gfc_conv_string_parameter (se
);
2790 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2795 /* Unary ops are easy... Or they would be if ! was a valid op. */
2798 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2803 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2804 /* Initialize the operand. */
2805 gfc_init_se (&operand
, se
);
2806 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2807 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2809 type
= gfc_typenode_for_spec (&expr
->ts
);
2811 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2812 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2813 All other unary operators have an equivalent GIMPLE unary operator. */
2814 if (code
== TRUTH_NOT_EXPR
)
2815 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2816 build_int_cst (type
, 0));
2818 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2822 /* Expand power operator to optimal multiplications when a value is raised
2823 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2824 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2825 Programming", 3rd Edition, 1998. */
2827 /* This code is mostly duplicated from expand_powi in the backend.
2828 We establish the "optimal power tree" lookup table with the defined size.
2829 The items in the table are the exponents used to calculate the index
2830 exponents. Any integer n less than the value can get an "addition chain",
2831 with the first node being one. */
2832 #define POWI_TABLE_SIZE 256
2834 /* The table is from builtins.c. */
2835 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2837 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2838 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2839 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2840 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2841 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2842 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2843 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2844 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2845 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2846 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2847 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2848 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2849 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2850 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2851 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2852 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2853 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2854 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2855 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2856 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2857 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2858 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2859 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2860 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2861 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2862 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2863 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2864 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2865 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2866 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2867 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2868 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2871 /* If n is larger than lookup table's max index, we use the "window
2873 #define POWI_WINDOW_SIZE 3
2875 /* Recursive function to expand the power operator. The temporary
2876 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2878 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2885 if (n
< POWI_TABLE_SIZE
)
2890 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2891 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2895 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2896 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2897 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2901 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2905 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2906 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2908 if (n
< POWI_TABLE_SIZE
)
2915 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2916 return 1. Else return 0 and a call to runtime library functions
2917 will have to be built. */
2919 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2924 tree vartmp
[POWI_TABLE_SIZE
];
2926 unsigned HOST_WIDE_INT n
;
2928 wide_int wrhs
= rhs
;
2930 /* If exponent is too large, we won't expand it anyway, so don't bother
2931 with large integer values. */
2932 if (!wi::fits_shwi_p (wrhs
))
2935 m
= wrhs
.to_shwi ();
2936 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2937 of the asymmetric range of the integer type. */
2938 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2940 type
= TREE_TYPE (lhs
);
2941 sgn
= tree_int_cst_sgn (rhs
);
2943 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2944 || optimize_size
) && (m
> 2 || m
< -1))
2950 se
->expr
= gfc_build_const (type
, integer_one_node
);
2954 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2955 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2957 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2958 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2959 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2960 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2963 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2966 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2967 boolean_type_node
, tmp
, cond
);
2968 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2969 tmp
, build_int_cst (type
, 1),
2970 build_int_cst (type
, 0));
2974 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2975 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2976 build_int_cst (type
, -1),
2977 build_int_cst (type
, 0));
2978 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2979 cond
, build_int_cst (type
, 1), tmp
);
2983 memset (vartmp
, 0, sizeof (vartmp
));
2987 tmp
= gfc_build_const (type
, integer_one_node
);
2988 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2992 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2998 /* Power op (**). Constant integer exponent has special handling. */
3001 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
3003 tree gfc_int4_type_node
;
3006 int res_ikind_1
, res_ikind_2
;
3011 gfc_init_se (&lse
, se
);
3012 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
3013 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
3014 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3016 gfc_init_se (&rse
, se
);
3017 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
3018 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3020 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
3021 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
3022 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3025 gfc_int4_type_node
= gfc_get_int_type (4);
3027 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3028 library routine. But in the end, we have to convert the result back
3029 if this case applies -- with res_ikind_K, we keep track whether operand K
3030 falls into this case. */
3034 kind
= expr
->value
.op
.op1
->ts
.kind
;
3035 switch (expr
->value
.op
.op2
->ts
.type
)
3038 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3043 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3044 res_ikind_2
= ikind
;
3066 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3068 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3095 switch (expr
->value
.op
.op1
->ts
.type
)
3098 if (kind
== 3) /* Case 16 was not handled properly above. */
3100 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3104 /* Use builtins for real ** int4. */
3110 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3114 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3118 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3122 /* Use the __builtin_powil() only if real(kind=16) is
3123 actually the C long double type. */
3124 if (!gfc_real16_is_float128
)
3125 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3133 /* If we don't have a good builtin for this, go for the
3134 library function. */
3136 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3140 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3149 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3153 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3161 se
->expr
= build_call_expr_loc (input_location
,
3162 fndecl
, 2, lse
.expr
, rse
.expr
);
3164 /* Convert the result back if it is of wrong integer kind. */
3165 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3167 /* We want the maximum of both operand kinds as result. */
3168 if (res_ikind_1
< res_ikind_2
)
3169 res_ikind_1
= res_ikind_2
;
3170 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3175 /* Generate code to allocate a string temporary. */
3178 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3183 if (gfc_can_put_var_on_stack (len
))
3185 /* Create a temporary variable to hold the result. */
3186 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3187 gfc_charlen_type_node
, len
,
3188 build_int_cst (gfc_charlen_type_node
, 1));
3189 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3191 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3192 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3194 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3196 var
= gfc_create_var (tmp
, "str");
3197 var
= gfc_build_addr_expr (type
, var
);
3201 /* Allocate a temporary to hold the result. */
3202 var
= gfc_create_var (type
, "pstr");
3203 gcc_assert (POINTER_TYPE_P (type
));
3204 tmp
= TREE_TYPE (type
);
3205 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3206 tmp
= TREE_TYPE (tmp
);
3207 tmp
= TYPE_SIZE_UNIT (tmp
);
3208 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3209 fold_convert (size_type_node
, len
),
3210 fold_convert (size_type_node
, tmp
));
3211 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3212 gfc_add_modify (&se
->pre
, var
, tmp
);
3214 /* Free the temporary afterwards. */
3215 tmp
= gfc_call_free (var
);
3216 gfc_add_expr_to_block (&se
->post
, tmp
);
3223 /* Handle a string concatenation operation. A temporary will be allocated to
3227 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3230 tree len
, type
, var
, tmp
, fndecl
;
3232 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3233 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3234 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3236 gfc_init_se (&lse
, se
);
3237 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3238 gfc_conv_string_parameter (&lse
);
3239 gfc_init_se (&rse
, se
);
3240 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3241 gfc_conv_string_parameter (&rse
);
3243 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3244 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3246 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3247 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3248 if (len
== NULL_TREE
)
3250 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3251 TREE_TYPE (lse
.string_length
),
3252 lse
.string_length
, rse
.string_length
);
3255 type
= build_pointer_type (type
);
3257 var
= gfc_conv_string_tmp (se
, type
, len
);
3259 /* Do the actual concatenation. */
3260 if (expr
->ts
.kind
== 1)
3261 fndecl
= gfor_fndecl_concat_string
;
3262 else if (expr
->ts
.kind
== 4)
3263 fndecl
= gfor_fndecl_concat_string_char4
;
3267 tmp
= build_call_expr_loc (input_location
,
3268 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3269 rse
.string_length
, rse
.expr
);
3270 gfc_add_expr_to_block (&se
->pre
, tmp
);
3272 /* Add the cleanup for the operands. */
3273 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3274 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3277 se
->string_length
= len
;
3280 /* Translates an op expression. Common (binary) cases are handled by this
3281 function, others are passed on. Recursion is used in either case.
3282 We use the fact that (op1.ts == op2.ts) (except for the power
3284 Operators need no special handling for scalarized expressions as long as
3285 they call gfc_conv_simple_val to get their operands.
3286 Character strings get special handling. */
3289 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3291 enum tree_code code
;
3300 switch (expr
->value
.op
.op
)
3302 case INTRINSIC_PARENTHESES
:
3303 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3304 && flag_protect_parens
)
3306 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3307 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3312 case INTRINSIC_UPLUS
:
3313 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3316 case INTRINSIC_UMINUS
:
3317 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3321 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3324 case INTRINSIC_PLUS
:
3328 case INTRINSIC_MINUS
:
3332 case INTRINSIC_TIMES
:
3336 case INTRINSIC_DIVIDE
:
3337 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3338 an integer, we must round towards zero, so we use a
3340 if (expr
->ts
.type
== BT_INTEGER
)
3341 code
= TRUNC_DIV_EXPR
;
3346 case INTRINSIC_POWER
:
3347 gfc_conv_power_op (se
, expr
);
3350 case INTRINSIC_CONCAT
:
3351 gfc_conv_concat_op (se
, expr
);
3355 code
= TRUTH_ANDIF_EXPR
;
3360 code
= TRUTH_ORIF_EXPR
;
3364 /* EQV and NEQV only work on logicals, but since we represent them
3365 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3367 case INTRINSIC_EQ_OS
:
3375 case INTRINSIC_NE_OS
:
3376 case INTRINSIC_NEQV
:
3383 case INTRINSIC_GT_OS
:
3390 case INTRINSIC_GE_OS
:
3397 case INTRINSIC_LT_OS
:
3404 case INTRINSIC_LE_OS
:
3410 case INTRINSIC_USER
:
3411 case INTRINSIC_ASSIGN
:
3412 /* These should be converted into function calls by the frontend. */
3416 fatal_error (input_location
, "Unknown intrinsic op");
3420 /* The only exception to this is **, which is handled separately anyway. */
3421 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3423 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3427 gfc_init_se (&lse
, se
);
3428 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3429 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3432 gfc_init_se (&rse
, se
);
3433 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3434 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3438 gfc_conv_string_parameter (&lse
);
3439 gfc_conv_string_parameter (&rse
);
3441 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3442 rse
.string_length
, rse
.expr
,
3443 expr
->value
.op
.op1
->ts
.kind
,
3445 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3446 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3449 type
= gfc_typenode_for_spec (&expr
->ts
);
3453 /* The result of logical ops is always boolean_type_node. */
3454 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3455 lse
.expr
, rse
.expr
);
3456 se
->expr
= convert (type
, tmp
);
3459 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3461 /* Add the post blocks. */
3462 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3463 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3466 /* If a string's length is one, we convert it to a single character. */
3469 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3473 || !tree_fits_uhwi_p (len
)
3474 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3477 if (TREE_INT_CST_LOW (len
) == 1)
3479 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3480 return build_fold_indirect_ref_loc (input_location
, str
);
3484 && TREE_CODE (str
) == ADDR_EXPR
3485 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3486 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3487 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3488 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3489 && TREE_INT_CST_LOW (len
) > 1
3490 && TREE_INT_CST_LOW (len
)
3491 == (unsigned HOST_WIDE_INT
)
3492 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3494 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3495 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3496 if (TREE_CODE (ret
) == INTEGER_CST
)
3498 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3499 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3500 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3502 for (i
= 1; i
< length
; i
++)
3515 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3518 if (sym
->backend_decl
)
3520 /* This becomes the nominal_type in
3521 function.c:assign_parm_find_data_types. */
3522 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3523 /* This becomes the passed_type in
3524 function.c:assign_parm_find_data_types. C promotes char to
3525 integer for argument passing. */
3526 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3528 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3533 /* If we have a constant character expression, make it into an
3535 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3540 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3541 (int)(*expr
)->value
.character
.string
[0]);
3542 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3544 /* The expr needs to be compatible with a C int. If the
3545 conversion fails, then the 2 causes an ICE. */
3546 ts
.type
= BT_INTEGER
;
3547 ts
.kind
= gfc_c_int_kind
;
3548 gfc_convert_type (*expr
, &ts
, 2);
3551 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3553 if ((*expr
)->ref
== NULL
)
3555 se
->expr
= gfc_string_to_single_character
3556 (build_int_cst (integer_type_node
, 1),
3557 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3559 ((*expr
)->symtree
->n
.sym
)),
3564 gfc_conv_variable (se
, *expr
);
3565 se
->expr
= gfc_string_to_single_character
3566 (build_int_cst (integer_type_node
, 1),
3567 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3575 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3576 if STR is a string literal, otherwise return -1. */
3579 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3582 && TREE_CODE (str
) == ADDR_EXPR
3583 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3584 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3585 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3586 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3587 && tree_fits_uhwi_p (len
)
3588 && tree_to_uhwi (len
) >= 1
3589 && tree_to_uhwi (len
)
3590 == (unsigned HOST_WIDE_INT
)
3591 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3593 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3594 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3595 if (TREE_CODE (folded
) == INTEGER_CST
)
3597 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3598 int length
= TREE_STRING_LENGTH (string_cst
);
3599 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3601 for (; length
> 0; length
--)
3602 if (ptr
[length
- 1] != ' ')
3611 /* Helper to build a call to memcmp. */
3614 build_memcmp_call (tree s1
, tree s2
, tree n
)
3618 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3619 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3621 s1
= fold_convert (pvoid_type_node
, s1
);
3623 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3624 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3626 s2
= fold_convert (pvoid_type_node
, s2
);
3628 n
= fold_convert (size_type_node
, n
);
3630 tmp
= build_call_expr_loc (input_location
,
3631 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3634 return fold_convert (integer_type_node
, tmp
);
3637 /* Compare two strings. If they are all single characters, the result is the
3638 subtraction of them. Otherwise, we build a library call. */
3641 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3642 enum tree_code code
)
3648 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3649 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3651 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3652 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3654 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3656 /* Deal with single character specially. */
3657 sc1
= fold_convert (integer_type_node
, sc1
);
3658 sc2
= fold_convert (integer_type_node
, sc2
);
3659 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3663 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3665 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3667 /* If one string is a string literal with LEN_TRIM longer
3668 than the length of the second string, the strings
3670 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3671 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3672 return integer_one_node
;
3673 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3674 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3675 return integer_one_node
;
3678 /* We can compare via memcpy if the strings are known to be equal
3679 in length and they are
3681 - kind=4 and the comparison is for (in)equality. */
3683 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3684 && tree_int_cst_equal (len1
, len2
)
3685 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3690 chartype
= gfc_get_char_type (kind
);
3691 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3692 fold_convert (TREE_TYPE(len1
),
3693 TYPE_SIZE_UNIT(chartype
)),
3695 return build_memcmp_call (str1
, str2
, tmp
);
3698 /* Build a call for the comparison. */
3700 fndecl
= gfor_fndecl_compare_string
;
3702 fndecl
= gfor_fndecl_compare_string_char4
;
3706 return build_call_expr_loc (input_location
, fndecl
, 4,
3707 len1
, str1
, len2
, str2
);
3711 /* Return the backend_decl for a procedure pointer component. */
3714 get_proc_ptr_comp (gfc_expr
*e
)
3720 gfc_init_se (&comp_se
, NULL
);
3721 e2
= gfc_copy_expr (e
);
3722 /* We have to restore the expr type later so that gfc_free_expr frees
3723 the exact same thing that was allocated.
3724 TODO: This is ugly. */
3725 old_type
= e2
->expr_type
;
3726 e2
->expr_type
= EXPR_VARIABLE
;
3727 gfc_conv_expr (&comp_se
, e2
);
3728 e2
->expr_type
= old_type
;
3730 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3734 /* Convert a typebound function reference from a class object. */
3736 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3741 if (TREE_CODE (base_object
) != VAR_DECL
)
3743 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3744 gfc_add_modify (&se
->pre
, var
, base_object
);
3746 se
->expr
= gfc_class_vptr_get (base_object
);
3747 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3749 while (ref
&& ref
->next
)
3751 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3752 if (ref
->u
.c
.sym
->attr
.extension
)
3753 conv_parent_component_references (se
, ref
);
3754 gfc_conv_component_ref (se
, ref
);
3755 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3760 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3764 if (gfc_is_proc_ptr_comp (expr
))
3765 tmp
= get_proc_ptr_comp (expr
);
3766 else if (sym
->attr
.dummy
)
3768 tmp
= gfc_get_symbol_decl (sym
);
3769 if (sym
->attr
.proc_pointer
)
3770 tmp
= build_fold_indirect_ref_loc (input_location
,
3772 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3773 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3777 if (!sym
->backend_decl
)
3778 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3780 TREE_USED (sym
->backend_decl
) = 1;
3782 tmp
= sym
->backend_decl
;
3784 if (sym
->attr
.cray_pointee
)
3786 /* TODO - make the cray pointee a pointer to a procedure,
3787 assign the pointer to it and use it for the call. This
3789 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3790 gfc_get_symbol_decl (sym
->cp_pointer
));
3791 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3794 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3796 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3797 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3804 /* Initialize MAPPING. */
3807 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3809 mapping
->syms
= NULL
;
3810 mapping
->charlens
= NULL
;
3814 /* Free all memory held by MAPPING (but not MAPPING itself). */
3817 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3819 gfc_interface_sym_mapping
*sym
;
3820 gfc_interface_sym_mapping
*nextsym
;
3822 gfc_charlen
*nextcl
;
3824 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3826 nextsym
= sym
->next
;
3827 sym
->new_sym
->n
.sym
->formal
= NULL
;
3828 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3829 gfc_free_expr (sym
->expr
);
3830 free (sym
->new_sym
);
3833 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3836 gfc_free_expr (cl
->length
);
3842 /* Return a copy of gfc_charlen CL. Add the returned structure to
3843 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3845 static gfc_charlen
*
3846 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3849 gfc_charlen
*new_charlen
;
3851 new_charlen
= gfc_get_charlen ();
3852 new_charlen
->next
= mapping
->charlens
;
3853 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3855 mapping
->charlens
= new_charlen
;
3860 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3861 array variable that can be used as the actual argument for dummy
3862 argument SYM. Add any initialization code to BLOCK. PACKED is as
3863 for gfc_get_nodesc_array_type and DATA points to the first element
3864 in the passed array. */
3867 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3868 gfc_packed packed
, tree data
)
3873 type
= gfc_typenode_for_spec (&sym
->ts
);
3874 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3875 !sym
->attr
.target
&& !sym
->attr
.pointer
3876 && !sym
->attr
.proc_pointer
);
3878 var
= gfc_create_var (type
, "ifm");
3879 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3885 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3886 and offset of descriptorless array type TYPE given that it has the same
3887 size as DESC. Add any set-up code to BLOCK. */
3890 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3897 offset
= gfc_index_zero_node
;
3898 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3900 dim
= gfc_rank_cst
[n
];
3901 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3902 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3904 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3905 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3906 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3907 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3909 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3911 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3912 gfc_array_index_type
,
3913 gfc_conv_descriptor_ubound_get (desc
, dim
),
3914 gfc_conv_descriptor_lbound_get (desc
, dim
));
3915 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3916 gfc_array_index_type
,
3917 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3918 tmp
= gfc_evaluate_now (tmp
, block
);
3919 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3921 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3922 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3923 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3924 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3925 gfc_array_index_type
, offset
, tmp
);
3927 offset
= gfc_evaluate_now (offset
, block
);
3928 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3932 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3933 in SE. The caller may still use se->expr and se->string_length after
3934 calling this function. */
3937 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3938 gfc_symbol
* sym
, gfc_se
* se
,
3941 gfc_interface_sym_mapping
*sm
;
3945 gfc_symbol
*new_sym
;
3947 gfc_symtree
*new_symtree
;
3949 /* Create a new symbol to represent the actual argument. */
3950 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3951 new_sym
->ts
= sym
->ts
;
3952 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3953 new_sym
->attr
.referenced
= 1;
3954 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3955 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3956 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3957 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3958 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3959 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3960 new_sym
->attr
.function
= sym
->attr
.function
;
3962 /* Ensure that the interface is available and that
3963 descriptors are passed for array actual arguments. */
3964 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3966 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3967 new_sym
->attr
.always_explicit
3968 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3971 /* Create a fake symtree for it. */
3973 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3974 new_symtree
->n
.sym
= new_sym
;
3975 gcc_assert (new_symtree
== root
);
3977 /* Create a dummy->actual mapping. */
3978 sm
= XCNEW (gfc_interface_sym_mapping
);
3979 sm
->next
= mapping
->syms
;
3981 sm
->new_sym
= new_symtree
;
3982 sm
->expr
= gfc_copy_expr (expr
);
3985 /* Stabilize the argument's value. */
3986 if (!sym
->attr
.function
&& se
)
3987 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3989 if (sym
->ts
.type
== BT_CHARACTER
)
3991 /* Create a copy of the dummy argument's length. */
3992 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3993 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3995 /* If the length is specified as "*", record the length that
3996 the caller is passing. We should use the callee's length
3997 in all other cases. */
3998 if (!new_sym
->ts
.u
.cl
->length
&& se
)
4000 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
4001 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
4008 /* Use the passed value as-is if the argument is a function. */
4009 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4012 /* If the argument is either a string or a pointer to a string,
4013 convert it to a boundless character type. */
4014 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
4016 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
4017 tmp
= build_pointer_type (tmp
);
4018 if (sym
->attr
.pointer
)
4019 value
= build_fold_indirect_ref_loc (input_location
,
4023 value
= fold_convert (tmp
, value
);
4026 /* If the argument is a scalar, a pointer to an array or an allocatable,
4028 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4029 value
= build_fold_indirect_ref_loc (input_location
,
4032 /* For character(*), use the actual argument's descriptor. */
4033 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4034 value
= build_fold_indirect_ref_loc (input_location
,
4037 /* If the argument is an array descriptor, use it to determine
4038 information about the actual argument's shape. */
4039 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4040 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4042 /* Get the actual argument's descriptor. */
4043 desc
= build_fold_indirect_ref_loc (input_location
,
4046 /* Create the replacement variable. */
4047 tmp
= gfc_conv_descriptor_data_get (desc
);
4048 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4051 /* Use DESC to work out the upper bounds, strides and offset. */
4052 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4055 /* Otherwise we have a packed array. */
4056 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4057 PACKED_FULL
, se
->expr
);
4059 new_sym
->backend_decl
= value
;
4063 /* Called once all dummy argument mappings have been added to MAPPING,
4064 but before the mapping is used to evaluate expressions. Pre-evaluate
4065 the length of each argument, adding any initialization code to PRE and
4066 any finalization code to POST. */
4069 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4070 stmtblock_t
* pre
, stmtblock_t
* post
)
4072 gfc_interface_sym_mapping
*sym
;
4076 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4077 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4078 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4080 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4081 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4082 gfc_init_se (&se
, NULL
);
4083 gfc_conv_expr (&se
, expr
);
4084 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4085 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4086 gfc_add_block_to_block (pre
, &se
.pre
);
4087 gfc_add_block_to_block (post
, &se
.post
);
4089 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4094 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4098 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4099 gfc_constructor_base base
)
4102 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4104 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4107 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4108 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4109 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4115 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4119 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4124 for (; ref
; ref
= ref
->next
)
4128 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4130 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4131 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4132 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4140 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4141 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4147 /* Convert intrinsic function calls into result expressions. */
4150 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4158 arg1
= expr
->value
.function
.actual
->expr
;
4159 if (expr
->value
.function
.actual
->next
)
4160 arg2
= expr
->value
.function
.actual
->next
->expr
;
4164 sym
= arg1
->symtree
->n
.sym
;
4166 if (sym
->attr
.dummy
)
4171 switch (expr
->value
.function
.isym
->id
)
4174 /* TODO figure out why this condition is necessary. */
4175 if (sym
->attr
.function
4176 && (arg1
->ts
.u
.cl
->length
== NULL
4177 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4178 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4181 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4185 if (!sym
->as
|| sym
->as
->rank
== 0)
4188 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4190 dup
= mpz_get_si (arg2
->value
.integer
);
4195 dup
= sym
->as
->rank
;
4199 for (; d
< dup
; d
++)
4203 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4205 gfc_free_expr (new_expr
);
4209 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4210 gfc_get_int_expr (gfc_default_integer_kind
,
4212 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4214 new_expr
= gfc_multiply (new_expr
, tmp
);
4220 case GFC_ISYM_LBOUND
:
4221 case GFC_ISYM_UBOUND
:
4222 /* TODO These implementations of lbound and ubound do not limit if
4223 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4225 if (!sym
->as
|| sym
->as
->rank
== 0)
4228 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4229 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4231 /* TODO: If the need arises, this could produce an array of
4235 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4237 if (sym
->as
->lower
[d
])
4238 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4242 if (sym
->as
->upper
[d
])
4243 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4251 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4255 gfc_replace_expr (expr
, new_expr
);
4261 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4262 gfc_interface_mapping
* mapping
)
4264 gfc_formal_arglist
*f
;
4265 gfc_actual_arglist
*actual
;
4267 actual
= expr
->value
.function
.actual
;
4268 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4270 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4275 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4278 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4283 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4285 for (d
= 0; d
< as
->rank
; d
++)
4287 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4288 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4291 expr
->value
.function
.esym
->as
= as
;
4294 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4296 expr
->value
.function
.esym
->ts
.u
.cl
->length
4297 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4299 gfc_apply_interface_mapping_to_expr (mapping
,
4300 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4305 /* EXPR is a copy of an expression that appeared in the interface
4306 associated with MAPPING. Walk it recursively looking for references to
4307 dummy arguments that MAPPING maps to actual arguments. Replace each such
4308 reference with a reference to the associated actual argument. */
4311 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4314 gfc_interface_sym_mapping
*sym
;
4315 gfc_actual_arglist
*actual
;
4320 /* Copying an expression does not copy its length, so do that here. */
4321 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4323 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4324 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4327 /* Apply the mapping to any references. */
4328 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4330 /* ...and to the expression's symbol, if it has one. */
4331 /* TODO Find out why the condition on expr->symtree had to be moved into
4332 the loop rather than being outside it, as originally. */
4333 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4334 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4336 if (sym
->new_sym
->n
.sym
->backend_decl
)
4337 expr
->symtree
= sym
->new_sym
;
4339 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4342 /* ...and to subexpressions in expr->value. */
4343 switch (expr
->expr_type
)
4348 case EXPR_SUBSTRING
:
4352 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4353 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4357 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4358 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4360 if (expr
->value
.function
.esym
== NULL
4361 && expr
->value
.function
.isym
!= NULL
4362 && expr
->value
.function
.actual
->expr
->symtree
4363 && gfc_map_intrinsic_function (expr
, mapping
))
4366 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4367 if (sym
->old
== expr
->value
.function
.esym
)
4369 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4370 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4371 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4376 case EXPR_STRUCTURE
:
4377 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4390 /* Evaluate interface expression EXPR using MAPPING. Store the result
4394 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4395 gfc_se
* se
, gfc_expr
* expr
)
4397 expr
= gfc_copy_expr (expr
);
4398 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4399 gfc_conv_expr (se
, expr
);
4400 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4401 gfc_free_expr (expr
);
4405 /* Returns a reference to a temporary array into which a component of
4406 an actual argument derived type array is copied and then returned
4407 after the function call. */
4409 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4410 sym_intent intent
, bool formal_ptr
)
4418 gfc_array_info
*info
;
4428 gfc_init_se (&lse
, NULL
);
4429 gfc_init_se (&rse
, NULL
);
4431 /* Walk the argument expression. */
4432 rss
= gfc_walk_expr (expr
);
4434 gcc_assert (rss
!= gfc_ss_terminator
);
4436 /* Initialize the scalarizer. */
4437 gfc_init_loopinfo (&loop
);
4438 gfc_add_ss_to_loop (&loop
, rss
);
4440 /* Calculate the bounds of the scalarization. */
4441 gfc_conv_ss_startstride (&loop
);
4443 /* Build an ss for the temporary. */
4444 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4445 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4447 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4448 if (GFC_ARRAY_TYPE_P (base_type
)
4449 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4450 base_type
= gfc_get_element_type (base_type
);
4452 if (expr
->ts
.type
== BT_CLASS
)
4453 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4455 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4456 ? expr
->ts
.u
.cl
->backend_decl
4460 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4462 /* Associate the SS with the loop. */
4463 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4465 /* Setup the scalarizing loops. */
4466 gfc_conv_loop_setup (&loop
, &expr
->where
);
4468 /* Pass the temporary descriptor back to the caller. */
4469 info
= &loop
.temp_ss
->info
->data
.array
;
4470 parmse
->expr
= info
->descriptor
;
4472 /* Setup the gfc_se structures. */
4473 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4474 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4477 lse
.ss
= loop
.temp_ss
;
4478 gfc_mark_ss_chain_used (rss
, 1);
4479 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4481 /* Start the scalarized loop body. */
4482 gfc_start_scalarized_body (&loop
, &body
);
4484 /* Translate the expression. */
4485 gfc_conv_expr (&rse
, expr
);
4487 /* Reset the offset for the function call since the loop
4488 is zero based on the data pointer. Note that the temp
4489 comes first in the loop chain since it is added second. */
4490 if (gfc_is_alloc_class_array_function (expr
))
4492 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4493 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4494 gfc_index_zero_node
);
4497 gfc_conv_tmp_array_ref (&lse
);
4499 if (intent
!= INTENT_OUT
)
4501 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4502 gfc_add_expr_to_block (&body
, tmp
);
4503 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4504 gfc_trans_scalarizing_loops (&loop
, &body
);
4508 /* Make sure that the temporary declaration survives by merging
4509 all the loop declarations into the current context. */
4510 for (n
= 0; n
< loop
.dimen
; n
++)
4512 gfc_merge_block_scope (&body
);
4513 body
= loop
.code
[loop
.order
[n
]];
4515 gfc_merge_block_scope (&body
);
4518 /* Add the post block after the second loop, so that any
4519 freeing of allocated memory is done at the right time. */
4520 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4522 /**********Copy the temporary back again.*********/
4524 gfc_init_se (&lse
, NULL
);
4525 gfc_init_se (&rse
, NULL
);
4527 /* Walk the argument expression. */
4528 lss
= gfc_walk_expr (expr
);
4529 rse
.ss
= loop
.temp_ss
;
4532 /* Initialize the scalarizer. */
4533 gfc_init_loopinfo (&loop2
);
4534 gfc_add_ss_to_loop (&loop2
, lss
);
4536 dimen
= rse
.ss
->dimen
;
4538 /* Skip the write-out loop for this case. */
4539 if (gfc_is_alloc_class_array_function (expr
))
4540 goto class_array_fcn
;
4542 /* Calculate the bounds of the scalarization. */
4543 gfc_conv_ss_startstride (&loop2
);
4545 /* Setup the scalarizing loops. */
4546 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4548 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4549 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4551 gfc_mark_ss_chain_used (lss
, 1);
4552 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4554 /* Declare the variable to hold the temporary offset and start the
4555 scalarized loop body. */
4556 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4557 gfc_start_scalarized_body (&loop2
, &body
);
4559 /* Build the offsets for the temporary from the loop variables. The
4560 temporary array has lbounds of zero and strides of one in all
4561 dimensions, so this is very simple. The offset is only computed
4562 outside the innermost loop, so the overall transfer could be
4563 optimized further. */
4564 info
= &rse
.ss
->info
->data
.array
;
4566 tmp_index
= gfc_index_zero_node
;
4567 for (n
= dimen
- 1; n
> 0; n
--)
4570 tmp
= rse
.loop
->loopvar
[n
];
4571 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4572 tmp
, rse
.loop
->from
[n
]);
4573 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4576 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4577 gfc_array_index_type
,
4578 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4579 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4580 gfc_array_index_type
,
4581 tmp_str
, gfc_index_one_node
);
4583 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4584 gfc_array_index_type
, tmp
, tmp_str
);
4587 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4588 gfc_array_index_type
,
4589 tmp_index
, rse
.loop
->from
[0]);
4590 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4592 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4593 gfc_array_index_type
,
4594 rse
.loop
->loopvar
[0], offset
);
4596 /* Now use the offset for the reference. */
4597 tmp
= build_fold_indirect_ref_loc (input_location
,
4599 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4601 if (expr
->ts
.type
== BT_CHARACTER
)
4602 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4604 gfc_conv_expr (&lse
, expr
);
4606 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4608 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4609 gfc_add_expr_to_block (&body
, tmp
);
4611 /* Generate the copying loops. */
4612 gfc_trans_scalarizing_loops (&loop2
, &body
);
4614 /* Wrap the whole thing up by adding the second loop to the post-block
4615 and following it by the post-block of the first loop. In this way,
4616 if the temporary needs freeing, it is done after use! */
4617 if (intent
!= INTENT_IN
)
4619 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4620 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4625 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4627 gfc_cleanup_loop (&loop
);
4628 gfc_cleanup_loop (&loop2
);
4630 /* Pass the string length to the argument expression. */
4631 if (expr
->ts
.type
== BT_CHARACTER
)
4632 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4634 /* Determine the offset for pointer formal arguments and set the
4638 size
= gfc_index_one_node
;
4639 offset
= gfc_index_zero_node
;
4640 for (n
= 0; n
< dimen
; n
++)
4642 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4644 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4645 gfc_array_index_type
, tmp
,
4646 gfc_index_one_node
);
4647 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4651 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4654 gfc_index_one_node
);
4655 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4656 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4657 gfc_array_index_type
,
4659 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4660 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4661 gfc_array_index_type
,
4662 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4663 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4664 gfc_array_index_type
,
4665 tmp
, gfc_index_one_node
);
4666 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4667 gfc_array_index_type
, size
, tmp
);
4670 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4674 /* We want either the address for the data or the address of the descriptor,
4675 depending on the mode of passing array arguments. */
4677 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4679 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4685 /* Generate the code for argument list functions. */
4688 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4690 /* Pass by value for g77 %VAL(arg), pass the address
4691 indirectly for %LOC, else by reference. Thus %REF
4692 is a "do-nothing" and %LOC is the same as an F95
4694 if (strncmp (name
, "%VAL", 4) == 0)
4695 gfc_conv_expr (se
, expr
);
4696 else if (strncmp (name
, "%LOC", 4) == 0)
4698 gfc_conv_expr_reference (se
, expr
);
4699 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4701 else if (strncmp (name
, "%REF", 4) == 0)
4702 gfc_conv_expr_reference (se
, expr
);
4704 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4708 /* This function tells whether the middle-end representation of the expression
4709 E given as input may point to data otherwise accessible through a variable
4711 It is assumed that the only expressions that may alias are variables,
4712 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4714 This function is used to decide whether freeing an expression's allocatable
4715 components is safe or should be avoided.
4717 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4718 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4719 is necessary because for array constructors, aliasing depends on how
4721 - If E is an array constructor used as argument to an elemental procedure,
4722 the array, which is generated through shallow copy by the scalarizer,
4723 is used directly and can alias the expressions it was copied from.
4724 - If E is an array constructor used as argument to a non-elemental
4725 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4726 the array as in the previous case, but then that array is used
4727 to initialize a new descriptor through deep copy. There is no alias
4728 possible in that case.
4729 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4733 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4737 if (e
->expr_type
== EXPR_VARIABLE
)
4739 else if (e
->expr_type
== EXPR_FUNCTION
)
4741 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4743 if (proc_ifc
->result
!= NULL
4744 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4745 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4746 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4747 || proc_ifc
->result
->attr
.pointer
))
4752 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4755 for (c
= gfc_constructor_first (e
->value
.constructor
);
4756 c
; c
= gfc_constructor_next (c
))
4758 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4765 /* Generate code for a procedure call. Note can return se->post != NULL.
4766 If se->direct_byref is set then se->expr contains the return parameter.
4767 Return nonzero, if the call has alternate specifiers.
4768 'expr' is only needed for procedure pointer components. */
4771 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4772 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4773 vec
<tree
, va_gc
> *append_args
)
4775 gfc_interface_mapping mapping
;
4776 vec
<tree
, va_gc
> *arglist
;
4777 vec
<tree
, va_gc
> *retargs
;
4781 gfc_array_info
*info
;
4788 vec
<tree
, va_gc
> *stringargs
;
4789 vec
<tree
, va_gc
> *optionalargs
;
4791 gfc_formal_arglist
*formal
;
4792 gfc_actual_arglist
*arg
;
4793 int has_alternate_specifier
= 0;
4794 bool need_interface_mapping
;
4802 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4803 gfc_component
*comp
= NULL
;
4810 optionalargs
= NULL
;
4815 comp
= gfc_get_proc_ptr_comp (expr
);
4817 bool elemental_proc
= (comp
4818 && comp
->ts
.interface
4819 && comp
->ts
.interface
->attr
.elemental
)
4820 || (comp
&& comp
->attr
.elemental
)
4821 || sym
->attr
.elemental
;
4825 if (!elemental_proc
)
4827 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4828 if (se
->ss
->info
->useflags
)
4830 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4831 && sym
->result
->attr
.dimension
)
4832 || (comp
&& comp
->attr
.dimension
)
4833 || gfc_is_alloc_class_array_function (expr
));
4834 gcc_assert (se
->loop
!= NULL
);
4835 /* Access the previously obtained result. */
4836 gfc_conv_tmp_array_ref (se
);
4840 info
= &se
->ss
->info
->data
.array
;
4845 gfc_init_block (&post
);
4846 gfc_init_interface_mapping (&mapping
);
4849 formal
= gfc_sym_get_dummy_args (sym
);
4850 need_interface_mapping
= sym
->attr
.dimension
||
4851 (sym
->ts
.type
== BT_CHARACTER
4852 && sym
->ts
.u
.cl
->length
4853 && sym
->ts
.u
.cl
->length
->expr_type
4858 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4859 need_interface_mapping
= comp
->attr
.dimension
||
4860 (comp
->ts
.type
== BT_CHARACTER
4861 && comp
->ts
.u
.cl
->length
4862 && comp
->ts
.u
.cl
->length
->expr_type
4866 base_object
= NULL_TREE
;
4867 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4868 is the third and fourth argument to such a function call a value
4869 denoting the number of elements to copy (i.e., most of the time the
4870 length of a deferred length string). */
4871 ulim_copy
= (formal
== NULL
)
4872 && UNLIMITED_POLY (sym
)
4873 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4875 /* Evaluate the arguments. */
4876 for (arg
= args
, argc
= 0; arg
!= NULL
;
4877 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4880 fsym
= formal
? formal
->sym
: NULL
;
4881 parm_kind
= MISSING
;
4883 /* If the procedure requires an explicit interface, the actual
4884 argument is passed according to the corresponding formal
4885 argument. If the corresponding formal argument is a POINTER,
4886 ALLOCATABLE or assumed shape, we do not use g77's calling
4887 convention, and pass the address of the array descriptor
4888 instead. Otherwise we use g77's calling convention, in other words
4889 pass the array data pointer without descriptor. */
4890 bool nodesc_arg
= fsym
!= NULL
4891 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4893 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4894 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4896 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4898 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4900 /* Class array expressions are sometimes coming completely unadorned
4901 with either arrayspec or _data component. Correct that here.
4902 OOP-TODO: Move this to the frontend. */
4903 if (e
&& e
->expr_type
== EXPR_VARIABLE
4905 && e
->ts
.type
== BT_CLASS
4906 && (CLASS_DATA (e
)->attr
.codimension
4907 || CLASS_DATA (e
)->attr
.dimension
))
4909 gfc_typespec temp_ts
= e
->ts
;
4910 gfc_add_class_array_ref (e
);
4916 if (se
->ignore_optional
)
4918 /* Some intrinsics have already been resolved to the correct
4922 else if (arg
->label
)
4924 has_alternate_specifier
= 1;
4929 gfc_init_se (&parmse
, NULL
);
4931 /* For scalar arguments with VALUE attribute which are passed by
4932 value, pass "0" and a hidden argument gives the optional
4934 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4935 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4936 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4938 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4940 vec_safe_push (optionalargs
, boolean_false_node
);
4944 /* Pass a NULL pointer for an absent arg. */
4945 parmse
.expr
= null_pointer_node
;
4946 if (arg
->missing_arg_type
== BT_CHARACTER
)
4947 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4952 else if (arg
->expr
->expr_type
== EXPR_NULL
4953 && fsym
&& !fsym
->attr
.pointer
4954 && (fsym
->ts
.type
!= BT_CLASS
4955 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4957 /* Pass a NULL pointer to denote an absent arg. */
4958 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4959 && (fsym
->ts
.type
!= BT_CLASS
4960 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4961 gfc_init_se (&parmse
, NULL
);
4962 parmse
.expr
= null_pointer_node
;
4963 if (arg
->missing_arg_type
== BT_CHARACTER
)
4964 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4966 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4967 && e
->ts
.type
== BT_DERIVED
)
4969 /* The derived type needs to be converted to a temporary
4971 gfc_init_se (&parmse
, se
);
4972 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4974 && e
->expr_type
== EXPR_VARIABLE
4975 && e
->symtree
->n
.sym
->attr
.optional
,
4976 CLASS_DATA (fsym
)->attr
.class_pointer
4977 || CLASS_DATA (fsym
)->attr
.allocatable
);
4979 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4981 /* The intrinsic type needs to be converted to a temporary
4982 CLASS object for the unlimited polymorphic formal. */
4983 gfc_init_se (&parmse
, se
);
4984 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4986 else if (se
->ss
&& se
->ss
->info
->useflags
)
4992 /* An elemental function inside a scalarized loop. */
4993 gfc_init_se (&parmse
, se
);
4994 parm_kind
= ELEMENTAL
;
4996 /* When no fsym is present, ulim_copy is set and this is a third or
4997 fourth argument, use call-by-value instead of by reference to
4998 hand the length properties to the copy routine (i.e., most of the
4999 time this will be a call to a __copy_character_* routine where the
5000 third and fourth arguments are the lengths of a deferred length
5002 if ((fsym
&& fsym
->attr
.value
)
5003 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
5004 gfc_conv_expr (&parmse
, e
);
5006 gfc_conv_expr_reference (&parmse
, e
);
5008 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
5009 && e
->expr_type
== EXPR_FUNCTION
)
5010 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5013 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5014 && gfc_is_class_container_ref (e
))
5016 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5018 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5019 && e
->symtree
->n
.sym
->attr
.optional
)
5021 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5022 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5023 TREE_TYPE (parmse
.expr
),
5025 fold_convert (TREE_TYPE (parmse
.expr
),
5026 null_pointer_node
));
5030 /* If we are passing an absent array as optional dummy to an
5031 elemental procedure, make sure that we pass NULL when the data
5032 pointer is NULL. We need this extra conditional because of
5033 scalarization which passes arrays elements to the procedure,
5034 ignoring the fact that the array can be absent/unallocated/... */
5035 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5037 tree descriptor_data
;
5039 descriptor_data
= ss
->info
->data
.array
.data
;
5040 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5042 fold_convert (TREE_TYPE (descriptor_data
),
5043 null_pointer_node
));
5045 = fold_build3_loc (input_location
, COND_EXPR
,
5046 TREE_TYPE (parmse
.expr
),
5047 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5048 fold_convert (TREE_TYPE (parmse
.expr
),
5053 /* The scalarizer does not repackage the reference to a class
5054 array - instead it returns a pointer to the data element. */
5055 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5056 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5057 fsym
->attr
.intent
!= INTENT_IN
5058 && (CLASS_DATA (fsym
)->attr
.class_pointer
5059 || CLASS_DATA (fsym
)->attr
.allocatable
),
5061 && e
->expr_type
== EXPR_VARIABLE
5062 && e
->symtree
->n
.sym
->attr
.optional
,
5063 CLASS_DATA (fsym
)->attr
.class_pointer
5064 || CLASS_DATA (fsym
)->attr
.allocatable
);
5071 gfc_init_se (&parmse
, NULL
);
5073 /* Check whether the expression is a scalar or not; we cannot use
5074 e->rank as it can be nonzero for functions arguments. */
5075 argss
= gfc_walk_expr (e
);
5076 scalar
= argss
== gfc_ss_terminator
;
5078 gfc_free_ss_chain (argss
);
5080 /* Special handling for passing scalar polymorphic coarrays;
5081 otherwise one passes "class->_data.data" instead of "&class". */
5082 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5083 && fsym
&& fsym
->ts
.type
== BT_CLASS
5084 && CLASS_DATA (fsym
)->attr
.codimension
5085 && !CLASS_DATA (fsym
)->attr
.dimension
)
5087 gfc_add_class_array_ref (e
);
5088 parmse
.want_coarray
= 1;
5092 /* A scalar or transformational function. */
5095 if (e
->expr_type
== EXPR_VARIABLE
5096 && e
->symtree
->n
.sym
->attr
.cray_pointee
5097 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5099 /* The Cray pointer needs to be converted to a pointer to
5100 a type given by the expression. */
5101 gfc_conv_expr (&parmse
, e
);
5102 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5103 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5104 parmse
.expr
= convert (type
, tmp
);
5106 else if (fsym
&& fsym
->attr
.value
)
5108 if (fsym
->ts
.type
== BT_CHARACTER
5109 && fsym
->ts
.is_c_interop
5110 && fsym
->ns
->proc_name
!= NULL
5111 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5114 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5115 if (parmse
.expr
== NULL
)
5116 gfc_conv_expr (&parmse
, e
);
5120 gfc_conv_expr (&parmse
, e
);
5121 if (fsym
->attr
.optional
5122 && fsym
->ts
.type
!= BT_CLASS
5123 && fsym
->ts
.type
!= BT_DERIVED
)
5125 if (e
->expr_type
!= EXPR_VARIABLE
5126 || !e
->symtree
->n
.sym
->attr
.optional
5128 vec_safe_push (optionalargs
, boolean_true_node
);
5131 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5132 if (!e
->symtree
->n
.sym
->attr
.value
)
5134 = fold_build3_loc (input_location
, COND_EXPR
,
5135 TREE_TYPE (parmse
.expr
),
5137 fold_convert (TREE_TYPE (parmse
.expr
),
5138 integer_zero_node
));
5140 vec_safe_push (optionalargs
, tmp
);
5145 else if (arg
->name
&& arg
->name
[0] == '%')
5146 /* Argument list functions %VAL, %LOC and %REF are signalled
5147 through arg->name. */
5148 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5149 else if ((e
->expr_type
== EXPR_FUNCTION
)
5150 && ((e
->value
.function
.esym
5151 && e
->value
.function
.esym
->result
->attr
.pointer
)
5152 || (!e
->value
.function
.esym
5153 && e
->symtree
->n
.sym
->attr
.pointer
))
5154 && fsym
&& fsym
->attr
.target
)
5156 gfc_conv_expr (&parmse
, e
);
5157 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5159 else if (e
->expr_type
== EXPR_FUNCTION
5160 && e
->symtree
->n
.sym
->result
5161 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5162 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5164 /* Functions returning procedure pointers. */
5165 gfc_conv_expr (&parmse
, e
);
5166 if (fsym
&& fsym
->attr
.proc_pointer
)
5167 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5171 if (e
->ts
.type
== BT_CLASS
&& fsym
5172 && fsym
->ts
.type
== BT_CLASS
5173 && (!CLASS_DATA (fsym
)->as
5174 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5175 && CLASS_DATA (e
)->attr
.codimension
)
5177 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5178 gcc_assert (!CLASS_DATA (fsym
)->as
);
5179 gfc_add_class_array_ref (e
);
5180 parmse
.want_coarray
= 1;
5181 gfc_conv_expr_reference (&parmse
, e
);
5182 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5184 && e
->expr_type
== EXPR_VARIABLE
);
5186 else if (e
->ts
.type
== BT_CLASS
&& fsym
5187 && fsym
->ts
.type
== BT_CLASS
5188 && !CLASS_DATA (fsym
)->as
5189 && !CLASS_DATA (e
)->as
5190 && strcmp (fsym
->ts
.u
.derived
->name
,
5191 e
->ts
.u
.derived
->name
))
5193 type
= gfc_typenode_for_spec (&fsym
->ts
);
5194 var
= gfc_create_var (type
, fsym
->name
);
5195 gfc_conv_expr (&parmse
, e
);
5196 if (fsym
->attr
.optional
5197 && e
->expr_type
== EXPR_VARIABLE
5198 && e
->symtree
->n
.sym
->attr
.optional
)
5202 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5203 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5204 boolean_type_node
, tmp
,
5205 fold_convert (TREE_TYPE (tmp
),
5206 null_pointer_node
));
5207 gfc_start_block (&block
);
5208 gfc_add_modify (&block
, var
,
5209 fold_build1_loc (input_location
,
5211 type
, parmse
.expr
));
5212 gfc_add_expr_to_block (&parmse
.pre
,
5213 fold_build3_loc (input_location
,
5214 COND_EXPR
, void_type_node
,
5215 cond
, gfc_finish_block (&block
),
5216 build_empty_stmt (input_location
)));
5217 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5218 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5219 TREE_TYPE (parmse
.expr
),
5221 fold_convert (TREE_TYPE (parmse
.expr
),
5222 null_pointer_node
));
5226 gfc_add_modify (&parmse
.pre
, var
,
5227 fold_build1_loc (input_location
,
5229 type
, parmse
.expr
));
5230 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5234 gfc_conv_expr_reference (&parmse
, e
);
5236 /* Catch base objects that are not variables. */
5237 if (e
->ts
.type
== BT_CLASS
5238 && e
->expr_type
!= EXPR_VARIABLE
5239 && expr
&& e
== expr
->base_expr
)
5240 base_object
= build_fold_indirect_ref_loc (input_location
,
5243 /* A class array element needs converting back to be a
5244 class object, if the formal argument is a class object. */
5245 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5246 && e
->ts
.type
== BT_CLASS
5247 && ((CLASS_DATA (fsym
)->as
5248 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5249 || CLASS_DATA (e
)->attr
.dimension
))
5250 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5251 fsym
->attr
.intent
!= INTENT_IN
5252 && (CLASS_DATA (fsym
)->attr
.class_pointer
5253 || CLASS_DATA (fsym
)->attr
.allocatable
),
5255 && e
->expr_type
== EXPR_VARIABLE
5256 && e
->symtree
->n
.sym
->attr
.optional
,
5257 CLASS_DATA (fsym
)->attr
.class_pointer
5258 || CLASS_DATA (fsym
)->attr
.allocatable
);
5260 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5261 allocated on entry, it must be deallocated. */
5262 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5263 && (fsym
->attr
.allocatable
5264 || (fsym
->ts
.type
== BT_CLASS
5265 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5270 gfc_init_block (&block
);
5272 if (e
->ts
.type
== BT_CLASS
)
5273 ptr
= gfc_class_data_get (ptr
);
5275 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5277 gfc_add_expr_to_block (&block
, tmp
);
5278 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5279 void_type_node
, ptr
,
5281 gfc_add_expr_to_block (&block
, tmp
);
5283 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5285 gfc_add_modify (&block
, ptr
,
5286 fold_convert (TREE_TYPE (ptr
),
5287 null_pointer_node
));
5288 gfc_add_expr_to_block (&block
, tmp
);
5290 else if (fsym
->ts
.type
== BT_CLASS
)
5293 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5294 tmp
= gfc_get_symbol_decl (vtab
);
5295 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5296 ptr
= gfc_class_vptr_get (parmse
.expr
);
5297 gfc_add_modify (&block
, ptr
,
5298 fold_convert (TREE_TYPE (ptr
), tmp
));
5299 gfc_add_expr_to_block (&block
, tmp
);
5302 if (fsym
->attr
.optional
5303 && e
->expr_type
== EXPR_VARIABLE
5304 && e
->symtree
->n
.sym
->attr
.optional
)
5306 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5308 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5309 gfc_finish_block (&block
),
5310 build_empty_stmt (input_location
));
5313 tmp
= gfc_finish_block (&block
);
5315 gfc_add_expr_to_block (&se
->pre
, tmp
);
5318 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5319 || fsym
->ts
.type
== BT_ASSUMED
)
5320 && e
->ts
.type
== BT_CLASS
5321 && !CLASS_DATA (e
)->attr
.dimension
5322 && !CLASS_DATA (e
)->attr
.codimension
)
5323 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5325 /* Wrap scalar variable in a descriptor. We need to convert
5326 the address of a pointer back to the pointer itself before,
5327 we can assign it to the data field. */
5329 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5330 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5333 if (TREE_CODE (tmp
) == ADDR_EXPR
5334 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5335 tmp
= TREE_OPERAND (tmp
, 0);
5336 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5338 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5341 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5342 && ((fsym
->attr
.pointer
5343 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5344 || (fsym
->attr
.proc_pointer
5345 && !(e
->expr_type
== EXPR_VARIABLE
5346 && e
->symtree
->n
.sym
->attr
.dummy
))
5347 || (fsym
->attr
.proc_pointer
5348 && e
->expr_type
== EXPR_VARIABLE
5349 && gfc_is_proc_ptr_comp (e
))
5350 || (fsym
->attr
.allocatable
5351 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5353 /* Scalar pointer dummy args require an extra level of
5354 indirection. The null pointer already contains
5355 this level of indirection. */
5356 parm_kind
= SCALAR_POINTER
;
5357 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5361 else if (e
->ts
.type
== BT_CLASS
5362 && fsym
&& fsym
->ts
.type
== BT_CLASS
5363 && (CLASS_DATA (fsym
)->attr
.dimension
5364 || CLASS_DATA (fsym
)->attr
.codimension
))
5366 /* Pass a class array. */
5367 parmse
.use_offset
= 1;
5368 gfc_conv_expr_descriptor (&parmse
, e
);
5370 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5371 allocated on entry, it must be deallocated. */
5372 if (fsym
->attr
.intent
== INTENT_OUT
5373 && CLASS_DATA (fsym
)->attr
.allocatable
)
5378 gfc_init_block (&block
);
5380 ptr
= gfc_class_data_get (ptr
);
5382 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5383 NULL_TREE
, NULL_TREE
,
5386 gfc_add_expr_to_block (&block
, tmp
);
5387 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5388 void_type_node
, ptr
,
5390 gfc_add_expr_to_block (&block
, tmp
);
5391 gfc_reset_vptr (&block
, e
);
5393 if (fsym
->attr
.optional
5394 && e
->expr_type
== EXPR_VARIABLE
5396 || (e
->ref
->type
== REF_ARRAY
5397 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5398 && e
->symtree
->n
.sym
->attr
.optional
)
5400 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5402 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5403 gfc_finish_block (&block
),
5404 build_empty_stmt (input_location
));
5407 tmp
= gfc_finish_block (&block
);
5409 gfc_add_expr_to_block (&se
->pre
, tmp
);
5412 /* The conversion does not repackage the reference to a class
5413 array - _data descriptor. */
5414 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5415 fsym
->attr
.intent
!= INTENT_IN
5416 && (CLASS_DATA (fsym
)->attr
.class_pointer
5417 || CLASS_DATA (fsym
)->attr
.allocatable
),
5419 && e
->expr_type
== EXPR_VARIABLE
5420 && e
->symtree
->n
.sym
->attr
.optional
,
5421 CLASS_DATA (fsym
)->attr
.class_pointer
5422 || CLASS_DATA (fsym
)->attr
.allocatable
);
5426 /* If the argument is a function call that may not create
5427 a temporary for the result, we have to check that we
5428 can do it, i.e. that there is no alias between this
5429 argument and another one. */
5430 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5436 intent
= fsym
->attr
.intent
;
5438 intent
= INTENT_UNKNOWN
;
5440 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5442 parmse
.force_tmp
= 1;
5444 iarg
= e
->value
.function
.actual
->expr
;
5446 /* Temporary needed if aliasing due to host association. */
5447 if (sym
->attr
.contained
5449 && !sym
->attr
.implicit_pure
5450 && !sym
->attr
.use_assoc
5451 && iarg
->expr_type
== EXPR_VARIABLE
5452 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5453 parmse
.force_tmp
= 1;
5455 /* Ditto within module. */
5456 if (sym
->attr
.use_assoc
5458 && !sym
->attr
.implicit_pure
5459 && iarg
->expr_type
== EXPR_VARIABLE
5460 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5461 parmse
.force_tmp
= 1;
5464 if (e
->expr_type
== EXPR_VARIABLE
5465 && is_subref_array (e
))
5466 /* The actual argument is a component reference to an
5467 array of derived types. In this case, the argument
5468 is converted to a temporary, which is passed and then
5469 written back after the procedure call. */
5470 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5471 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5472 fsym
&& fsym
->attr
.pointer
);
5473 else if (gfc_is_class_array_ref (e
, NULL
)
5474 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5475 /* The actual argument is a component reference to an
5476 array of derived types. In this case, the argument
5477 is converted to a temporary, which is passed and then
5478 written back after the procedure call.
5479 OOP-TODO: Insert code so that if the dynamic type is
5480 the same as the declared type, copy-in/copy-out does
5482 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5483 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5484 fsym
&& fsym
->attr
.pointer
);
5486 else if (gfc_is_alloc_class_array_function (e
)
5487 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5488 /* See previous comment. For function actual argument,
5489 the write out is not needed so the intent is set as
5492 e
->must_finalize
= 1;
5493 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5495 fsym
&& fsym
->attr
.pointer
);
5498 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5501 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5502 allocated on entry, it must be deallocated. */
5503 if (fsym
&& fsym
->attr
.allocatable
5504 && fsym
->attr
.intent
== INTENT_OUT
)
5506 tmp
= build_fold_indirect_ref_loc (input_location
,
5508 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5509 if (fsym
->attr
.optional
5510 && e
->expr_type
== EXPR_VARIABLE
5511 && e
->symtree
->n
.sym
->attr
.optional
)
5512 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5514 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5515 tmp
, build_empty_stmt (input_location
));
5516 gfc_add_expr_to_block (&se
->pre
, tmp
);
5521 /* The case with fsym->attr.optional is that of a user subroutine
5522 with an interface indicating an optional argument. When we call
5523 an intrinsic subroutine, however, fsym is NULL, but we might still
5524 have an optional argument, so we proceed to the substitution
5526 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5528 /* If an optional argument is itself an optional dummy argument,
5529 check its presence and substitute a null if absent. This is
5530 only needed when passing an array to an elemental procedure
5531 as then array elements are accessed - or no NULL pointer is
5532 allowed and a "1" or "0" should be passed if not present.
5533 When passing a non-array-descriptor full array to a
5534 non-array-descriptor dummy, no check is needed. For
5535 array-descriptor actual to array-descriptor dummy, see
5536 PR 41911 for why a check has to be inserted.
5537 fsym == NULL is checked as intrinsics required the descriptor
5538 but do not always set fsym. */
5539 if (e
->expr_type
== EXPR_VARIABLE
5540 && e
->symtree
->n
.sym
->attr
.optional
5541 && ((e
->rank
!= 0 && elemental_proc
)
5542 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5546 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5547 || fsym
->as
->type
== AS_ASSUMED_RANK
5548 || fsym
->as
->type
== AS_DEFERRED
))))))
5549 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5550 e
->representation
.length
);
5555 /* Obtain the character length of an assumed character length
5556 length procedure from the typespec. */
5557 if (fsym
->ts
.type
== BT_CHARACTER
5558 && parmse
.string_length
== NULL_TREE
5559 && e
->ts
.type
== BT_PROCEDURE
5560 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5561 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5562 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5564 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5565 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5569 if (fsym
&& need_interface_mapping
&& e
)
5570 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5572 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5573 gfc_add_block_to_block (&post
, &parmse
.post
);
5575 /* Allocated allocatable components of derived types must be
5576 deallocated for non-variable scalars, array arguments to elemental
5577 procedures, and array arguments with descriptor to non-elemental
5578 procedures. As bounds information for descriptorless arrays is no
5579 longer available here, they are dealt with in trans-array.c
5580 (gfc_conv_array_parameter). */
5581 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5582 && e
->ts
.u
.derived
->attr
.alloc_comp
5583 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5584 && !expr_may_alias_variables (e
, elemental_proc
))
5587 /* It is known the e returns a structure type with at least one
5588 allocatable component. When e is a function, ensure that the
5589 function is called once only by using a temporary variable. */
5590 if (!DECL_P (parmse
.expr
))
5591 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5592 parmse
.expr
, &se
->pre
);
5594 if (fsym
&& fsym
->attr
.value
)
5597 tmp
= build_fold_indirect_ref_loc (input_location
,
5600 parm_rank
= e
->rank
;
5608 case (SCALAR_POINTER
):
5609 tmp
= build_fold_indirect_ref_loc (input_location
,
5614 if (e
->expr_type
== EXPR_OP
5615 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5616 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5619 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5620 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5621 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5624 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5626 /* The derived type is passed to gfc_deallocate_alloc_comp.
5627 Therefore, class actuals can handled correctly but derived
5628 types passed to class formals need the _data component. */
5629 tmp
= gfc_class_data_get (tmp
);
5630 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5631 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5634 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5636 gfc_add_expr_to_block (&se
->post
, tmp
);
5639 /* Add argument checking of passing an unallocated/NULL actual to
5640 a nonallocatable/nonpointer dummy. */
5642 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5644 symbol_attribute attr
;
5648 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5649 attr
= gfc_expr_attr (e
);
5651 goto end_pointer_check
;
5653 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5654 allocatable to an optional dummy, cf. 12.5.2.12. */
5655 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5656 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5657 goto end_pointer_check
;
5661 /* If the actual argument is an optional pointer/allocatable and
5662 the formal argument takes an nonpointer optional value,
5663 it is invalid to pass a non-present argument on, even
5664 though there is no technical reason for this in gfortran.
5665 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5666 tree present
, null_ptr
, type
;
5668 if (attr
.allocatable
5669 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5670 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5671 "allocated or not present",
5672 e
->symtree
->n
.sym
->name
);
5673 else if (attr
.pointer
5674 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5675 msg
= xasprintf ("Pointer actual argument '%s' is not "
5676 "associated or not present",
5677 e
->symtree
->n
.sym
->name
);
5678 else if (attr
.proc_pointer
5679 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5680 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5681 "associated or not present",
5682 e
->symtree
->n
.sym
->name
);
5684 goto end_pointer_check
;
5686 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5687 type
= TREE_TYPE (present
);
5688 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5689 boolean_type_node
, present
,
5691 null_pointer_node
));
5692 type
= TREE_TYPE (parmse
.expr
);
5693 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5694 boolean_type_node
, parmse
.expr
,
5696 null_pointer_node
));
5697 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5698 boolean_type_node
, present
, null_ptr
);
5702 if (attr
.allocatable
5703 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5704 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5705 "allocated", e
->symtree
->n
.sym
->name
);
5706 else if (attr
.pointer
5707 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5708 msg
= xasprintf ("Pointer actual argument '%s' is not "
5709 "associated", e
->symtree
->n
.sym
->name
);
5710 else if (attr
.proc_pointer
5711 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5712 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5713 "associated", e
->symtree
->n
.sym
->name
);
5715 goto end_pointer_check
;
5719 /* If the argument is passed by value, we need to strip the
5721 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5722 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5724 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5725 boolean_type_node
, tmp
,
5726 fold_convert (TREE_TYPE (tmp
),
5727 null_pointer_node
));
5730 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5736 /* Deferred length dummies pass the character length by reference
5737 so that the value can be returned. */
5738 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5740 if (INDIRECT_REF_P (parmse
.string_length
))
5741 /* In chains of functions/procedure calls the string_length already
5742 is a pointer to the variable holding the length. Therefore
5743 remove the deref on call. */
5744 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5747 tmp
= parmse
.string_length
;
5748 if (TREE_CODE (tmp
) != VAR_DECL
5749 && TREE_CODE (tmp
) != COMPONENT_REF
)
5750 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5751 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5755 /* Character strings are passed as two parameters, a length and a
5756 pointer - except for Bind(c) which only passes the pointer.
5757 An unlimited polymorphic formal argument likewise does not
5759 if (parmse
.string_length
!= NULL_TREE
5760 && !sym
->attr
.is_bind_c
5761 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5762 vec_safe_push (stringargs
, parmse
.string_length
);
5764 /* When calling __copy for character expressions to unlimited
5765 polymorphic entities, the dst argument needs a string length. */
5766 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5767 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5768 && arg
->next
&& arg
->next
->expr
5769 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5770 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5771 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5772 vec_safe_push (stringargs
, parmse
.string_length
);
5774 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5775 pass the token and the offset as additional arguments. */
5776 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5777 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5778 && !fsym
->attr
.allocatable
)
5779 || (fsym
->ts
.type
== BT_CLASS
5780 && CLASS_DATA (fsym
)->attr
.codimension
5781 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5783 /* Token and offset. */
5784 vec_safe_push (stringargs
, null_pointer_node
);
5785 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5786 gcc_assert (fsym
->attr
.optional
);
5788 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5789 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5790 && !fsym
->attr
.allocatable
)
5791 || (fsym
->ts
.type
== BT_CLASS
5792 && CLASS_DATA (fsym
)->attr
.codimension
5793 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5795 tree caf_decl
, caf_type
;
5798 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5799 caf_type
= TREE_TYPE (caf_decl
);
5801 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5802 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5803 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5804 tmp
= gfc_conv_descriptor_token (caf_decl
);
5805 else if (DECL_LANG_SPECIFIC (caf_decl
)
5806 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5807 tmp
= GFC_DECL_TOKEN (caf_decl
);
5810 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5811 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5812 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5815 vec_safe_push (stringargs
, tmp
);
5817 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5818 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5819 offset
= build_int_cst (gfc_array_index_type
, 0);
5820 else if (DECL_LANG_SPECIFIC (caf_decl
)
5821 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5822 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5823 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5824 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5826 offset
= build_int_cst (gfc_array_index_type
, 0);
5828 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5829 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5832 gcc_assert (POINTER_TYPE_P (caf_type
));
5836 tmp2
= fsym
->ts
.type
== BT_CLASS
5837 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5838 if ((fsym
->ts
.type
!= BT_CLASS
5839 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5840 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5841 || (fsym
->ts
.type
== BT_CLASS
5842 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5843 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5845 if (fsym
->ts
.type
== BT_CLASS
)
5846 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5849 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5850 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5852 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5853 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5855 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5856 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5859 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5862 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5863 gfc_array_index_type
,
5864 fold_convert (gfc_array_index_type
, tmp2
),
5865 fold_convert (gfc_array_index_type
, tmp
));
5866 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5867 gfc_array_index_type
, offset
, tmp
);
5869 vec_safe_push (stringargs
, offset
);
5872 vec_safe_push (arglist
, parmse
.expr
);
5874 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5881 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5882 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5883 else if (ts
.type
== BT_CHARACTER
)
5885 if (ts
.u
.cl
->length
== NULL
)
5887 /* Assumed character length results are not allowed by 5.1.1.5 of the
5888 standard and are trapped in resolve.c; except in the case of SPREAD
5889 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5890 we take the character length of the first argument for the result.
5891 For dummies, we have to look through the formal argument list for
5892 this function and use the character length found there.*/
5894 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5895 else if (!sym
->attr
.dummy
)
5896 cl
.backend_decl
= (*stringargs
)[0];
5899 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5900 for (; formal
; formal
= formal
->next
)
5901 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5902 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5904 len
= cl
.backend_decl
;
5910 /* Calculate the length of the returned string. */
5911 gfc_init_se (&parmse
, NULL
);
5912 if (need_interface_mapping
)
5913 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5915 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5916 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5917 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5919 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5920 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5921 gfc_charlen_type_node
, tmp
,
5922 build_int_cst (gfc_charlen_type_node
, 0));
5923 cl
.backend_decl
= tmp
;
5926 /* Set up a charlen structure for it. */
5931 len
= cl
.backend_decl
;
5934 byref
= (comp
&& (comp
->attr
.dimension
5935 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5936 || (!comp
&& gfc_return_by_reference (sym
));
5939 if (se
->direct_byref
)
5941 /* Sometimes, too much indirection can be applied; e.g. for
5942 function_result = array_valued_recursive_function. */
5943 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5944 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5945 && GFC_DESCRIPTOR_TYPE_P
5946 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5947 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5950 /* If the lhs of an assignment x = f(..) is allocatable and
5951 f2003 is allowed, we must do the automatic reallocation.
5952 TODO - deal with intrinsics, without using a temporary. */
5953 if (flag_realloc_lhs
5954 && se
->ss
&& se
->ss
->loop_chain
5955 && se
->ss
->loop_chain
->is_alloc_lhs
5956 && !expr
->value
.function
.isym
5957 && sym
->result
->as
!= NULL
)
5959 /* Evaluate the bounds of the result, if known. */
5960 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5963 /* Perform the automatic reallocation. */
5964 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5966 gfc_add_expr_to_block (&se
->pre
, tmp
);
5968 /* Pass the temporary as the first argument. */
5969 result
= info
->descriptor
;
5972 result
= build_fold_indirect_ref_loc (input_location
,
5974 vec_safe_push (retargs
, se
->expr
);
5976 else if (comp
&& comp
->attr
.dimension
)
5978 gcc_assert (se
->loop
&& info
);
5980 /* Set the type of the array. */
5981 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5982 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5984 /* Evaluate the bounds of the result, if known. */
5985 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5987 /* If the lhs of an assignment x = f(..) is allocatable and
5988 f2003 is allowed, we must not generate the function call
5989 here but should just send back the results of the mapping.
5990 This is signalled by the function ss being flagged. */
5991 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5993 gfc_free_interface_mapping (&mapping
);
5994 return has_alternate_specifier
;
5997 /* Create a temporary to store the result. In case the function
5998 returns a pointer, the temporary will be a shallow copy and
5999 mustn't be deallocated. */
6000 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6001 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6002 tmp
, NULL_TREE
, false,
6003 !comp
->attr
.pointer
, callee_alloc
,
6004 &se
->ss
->info
->expr
->where
);
6006 /* Pass the temporary as the first argument. */
6007 result
= info
->descriptor
;
6008 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6009 vec_safe_push (retargs
, tmp
);
6011 else if (!comp
&& sym
->result
->attr
.dimension
)
6013 gcc_assert (se
->loop
&& info
);
6015 /* Set the type of the array. */
6016 tmp
= gfc_typenode_for_spec (&ts
);
6017 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6019 /* Evaluate the bounds of the result, if known. */
6020 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6022 /* If the lhs of an assignment x = f(..) is allocatable and
6023 f2003 is allowed, we must not generate the function call
6024 here but should just send back the results of the mapping.
6025 This is signalled by the function ss being flagged. */
6026 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6028 gfc_free_interface_mapping (&mapping
);
6029 return has_alternate_specifier
;
6032 /* Create a temporary to store the result. In case the function
6033 returns a pointer, the temporary will be a shallow copy and
6034 mustn't be deallocated. */
6035 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6036 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6037 tmp
, NULL_TREE
, false,
6038 !sym
->attr
.pointer
, callee_alloc
,
6039 &se
->ss
->info
->expr
->where
);
6041 /* Pass the temporary as the first argument. */
6042 result
= info
->descriptor
;
6043 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6044 vec_safe_push (retargs
, tmp
);
6046 else if (ts
.type
== BT_CHARACTER
)
6048 /* Pass the string length. */
6049 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6050 type
= build_pointer_type (type
);
6052 /* Return an address to a char[0:len-1]* temporary for
6053 character pointers. */
6054 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6055 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6057 var
= gfc_create_var (type
, "pstr");
6059 if ((!comp
&& sym
->attr
.allocatable
)
6060 || (comp
&& comp
->attr
.allocatable
))
6062 gfc_add_modify (&se
->pre
, var
,
6063 fold_convert (TREE_TYPE (var
),
6064 null_pointer_node
));
6065 tmp
= gfc_call_free (var
);
6066 gfc_add_expr_to_block (&se
->post
, tmp
);
6069 /* Provide an address expression for the function arguments. */
6070 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6073 var
= gfc_conv_string_tmp (se
, type
, len
);
6075 vec_safe_push (retargs
, var
);
6079 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6081 type
= gfc_get_complex_type (ts
.kind
);
6082 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6083 vec_safe_push (retargs
, var
);
6086 /* Add the string length to the argument list. */
6087 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6090 if (TREE_CODE (tmp
) != VAR_DECL
)
6091 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6092 TREE_STATIC (tmp
) = 1;
6093 gfc_add_modify (&se
->pre
, tmp
,
6094 build_int_cst (TREE_TYPE (tmp
), 0));
6095 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6096 vec_safe_push (retargs
, tmp
);
6098 else if (ts
.type
== BT_CHARACTER
)
6099 vec_safe_push (retargs
, len
);
6101 gfc_free_interface_mapping (&mapping
);
6103 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6104 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6105 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6106 vec_safe_reserve (retargs
, arglen
);
6108 /* Add the return arguments. */
6109 vec_safe_splice (retargs
, arglist
);
6111 /* Add the hidden present status for optional+value to the arguments. */
6112 vec_safe_splice (retargs
, optionalargs
);
6114 /* Add the hidden string length parameters to the arguments. */
6115 vec_safe_splice (retargs
, stringargs
);
6117 /* We may want to append extra arguments here. This is used e.g. for
6118 calls to libgfortran_matmul_??, which need extra information. */
6119 vec_safe_splice (retargs
, append_args
);
6123 /* Generate the actual call. */
6124 if (base_object
== NULL_TREE
)
6125 conv_function_val (se
, sym
, expr
);
6127 conv_base_obj_fcn_val (se
, base_object
, expr
);
6129 /* If there are alternate return labels, function type should be
6130 integer. Can't modify the type in place though, since it can be shared
6131 with other functions. For dummy arguments, the typing is done to
6132 this result, even if it has to be repeated for each call. */
6133 if (has_alternate_specifier
6134 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6136 if (!sym
->attr
.dummy
)
6138 TREE_TYPE (sym
->backend_decl
)
6139 = build_function_type (integer_type_node
,
6140 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6141 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6144 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6147 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6148 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6150 /* Allocatable scalar function results must be freed and nullified
6151 after use. This necessitates the creation of a temporary to
6152 hold the result to prevent duplicate calls. */
6153 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6154 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6156 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6157 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6159 tmp
= gfc_call_free (tmp
);
6160 gfc_add_expr_to_block (&post
, tmp
);
6161 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6164 /* If we have a pointer function, but we don't want a pointer, e.g.
6167 where f is pointer valued, we have to dereference the result. */
6168 if (!se
->want_pointer
&& !byref
6169 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6170 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6171 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6173 /* f2c calling conventions require a scalar default real function to
6174 return a double precision result. Convert this back to default
6175 real. We only care about the cases that can happen in Fortran 77.
6177 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6178 && sym
->ts
.kind
== gfc_default_real_kind
6179 && !sym
->attr
.always_explicit
)
6180 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6182 /* A pure function may still have side-effects - it may modify its
6184 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6186 if (!sym
->attr
.pure
)
6187 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6192 /* Add the function call to the pre chain. There is no expression. */
6193 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6194 se
->expr
= NULL_TREE
;
6196 if (!se
->direct_byref
)
6198 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6200 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6202 /* Check the data pointer hasn't been modified. This would
6203 happen in a function returning a pointer. */
6204 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6205 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6208 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6211 se
->expr
= info
->descriptor
;
6212 /* Bundle in the string length. */
6213 se
->string_length
= len
;
6215 else if (ts
.type
== BT_CHARACTER
)
6217 /* Dereference for character pointer results. */
6218 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6219 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6220 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6224 se
->string_length
= len
;
6228 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6229 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6234 /* Follow the function call with the argument post block. */
6237 gfc_add_block_to_block (&se
->pre
, &post
);
6239 /* Transformational functions of derived types with allocatable
6240 components must have the result allocatable components copied. */
6241 arg
= expr
->value
.function
.actual
;
6242 if (result
&& arg
&& expr
->rank
6243 && expr
->value
.function
.isym
6244 && expr
->value
.function
.isym
->transformational
6245 && arg
->expr
->ts
.type
== BT_DERIVED
6246 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6249 /* Copy the allocatable components. We have to use a
6250 temporary here to prevent source allocatable components
6251 from being corrupted. */
6252 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6253 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6254 result
, tmp2
, expr
->rank
);
6255 gfc_add_expr_to_block (&se
->pre
, tmp
);
6256 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6258 gfc_add_expr_to_block (&se
->pre
, tmp
);
6260 /* Finally free the temporary's data field. */
6261 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6262 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6263 NULL_TREE
, NULL_TREE
, true,
6265 gfc_add_expr_to_block (&se
->pre
, tmp
);
6270 /* For a function with a class array result, save the result as
6271 a temporary, set the info fields needed by the scalarizer and
6272 call the finalization function of the temporary. Note that the
6273 nullification of allocatable components needed by the result
6274 is done in gfc_trans_assignment_1. */
6275 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6276 && se
->ss
&& se
->ss
->loop
)
6277 || gfc_is_alloc_class_scalar_function (expr
))
6278 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6279 && expr
->must_finalize
)
6284 if (se
->ss
&& se
->ss
->loop
)
6286 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6287 tmp
= gfc_class_data_get (se
->expr
);
6288 info
->descriptor
= tmp
;
6289 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6290 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6291 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6293 tree dim
= gfc_rank_cst
[n
];
6294 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6295 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6300 /* TODO Eliminate the doubling of temporaries. This
6301 one is necessary to ensure no memory leakage. */
6302 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6303 tmp
= gfc_class_data_get (se
->expr
);
6304 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6305 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6308 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6309 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6312 fold_convert (TREE_TYPE (final_fndecl
),
6313 null_pointer_node
));
6314 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6316 tmp
= build_call_expr_loc (input_location
,
6318 gfc_build_addr_expr (NULL
, tmp
),
6319 gfc_class_vtab_size_get (se
->expr
),
6320 boolean_false_node
);
6321 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6322 void_type_node
, is_final
, tmp
,
6323 build_empty_stmt (input_location
));
6325 if (se
->ss
&& se
->ss
->loop
)
6327 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6328 tmp
= gfc_call_free (info
->data
);
6329 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6333 gfc_add_expr_to_block (&se
->post
, tmp
);
6334 tmp
= gfc_class_data_get (se
->expr
);
6335 tmp
= gfc_call_free (tmp
);
6336 gfc_add_expr_to_block (&se
->post
, tmp
);
6338 expr
->must_finalize
= 0;
6341 gfc_add_block_to_block (&se
->post
, &post
);
6344 return has_alternate_specifier
;
6348 /* Fill a character string with spaces. */
6351 fill_with_spaces (tree start
, tree type
, tree size
)
6353 stmtblock_t block
, loop
;
6354 tree i
, el
, exit_label
, cond
, tmp
;
6356 /* For a simple char type, we can call memset(). */
6357 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6358 return build_call_expr_loc (input_location
,
6359 builtin_decl_explicit (BUILT_IN_MEMSET
),
6361 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6362 lang_hooks
.to_target_charset (' ')),
6365 /* Otherwise, we use a loop:
6366 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6370 /* Initialize variables. */
6371 gfc_init_block (&block
);
6372 i
= gfc_create_var (sizetype
, "i");
6373 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6374 el
= gfc_create_var (build_pointer_type (type
), "el");
6375 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6376 exit_label
= gfc_build_label_decl (NULL_TREE
);
6377 TREE_USED (exit_label
) = 1;
6381 gfc_init_block (&loop
);
6383 /* Exit condition. */
6384 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6385 build_zero_cst (sizetype
));
6386 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6387 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6388 build_empty_stmt (input_location
));
6389 gfc_add_expr_to_block (&loop
, tmp
);
6392 gfc_add_modify (&loop
,
6393 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6394 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6396 /* Increment loop variables. */
6397 gfc_add_modify (&loop
, i
,
6398 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6399 TYPE_SIZE_UNIT (type
)));
6400 gfc_add_modify (&loop
, el
,
6401 fold_build_pointer_plus_loc (input_location
,
6402 el
, TYPE_SIZE_UNIT (type
)));
6404 /* Making the loop... actually loop! */
6405 tmp
= gfc_finish_block (&loop
);
6406 tmp
= build1_v (LOOP_EXPR
, tmp
);
6407 gfc_add_expr_to_block (&block
, tmp
);
6409 /* The exit label. */
6410 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6411 gfc_add_expr_to_block (&block
, tmp
);
6414 return gfc_finish_block (&block
);
6418 /* Generate code to copy a string. */
6421 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6422 int dkind
, tree slength
, tree src
, int skind
)
6424 tree tmp
, dlen
, slen
;
6433 stmtblock_t tempblock
;
6435 gcc_assert (dkind
== skind
);
6437 if (slength
!= NULL_TREE
)
6439 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6440 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6444 slen
= build_int_cst (size_type_node
, 1);
6448 if (dlength
!= NULL_TREE
)
6450 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6451 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6455 dlen
= build_int_cst (size_type_node
, 1);
6459 /* Assign directly if the types are compatible. */
6460 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6461 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6463 gfc_add_modify (block
, dsc
, ssc
);
6467 /* Do nothing if the destination length is zero. */
6468 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6469 build_int_cst (size_type_node
, 0));
6471 /* The following code was previously in _gfortran_copy_string:
6473 // The two strings may overlap so we use memmove.
6475 copy_string (GFC_INTEGER_4 destlen, char * dest,
6476 GFC_INTEGER_4 srclen, const char * src)
6478 if (srclen >= destlen)
6480 // This will truncate if too long.
6481 memmove (dest, src, destlen);
6485 memmove (dest, src, srclen);
6487 memset (&dest[srclen], ' ', destlen - srclen);
6491 We're now doing it here for better optimization, but the logic
6494 /* For non-default character kinds, we have to multiply the string
6495 length by the base type size. */
6496 chartype
= gfc_get_char_type (dkind
);
6497 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6498 fold_convert (size_type_node
, slen
),
6499 fold_convert (size_type_node
,
6500 TYPE_SIZE_UNIT (chartype
)));
6501 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6502 fold_convert (size_type_node
, dlen
),
6503 fold_convert (size_type_node
,
6504 TYPE_SIZE_UNIT (chartype
)));
6506 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6507 dest
= fold_convert (pvoid_type_node
, dest
);
6509 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6511 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6512 src
= fold_convert (pvoid_type_node
, src
);
6514 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6516 /* Truncate string if source is too long. */
6517 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6519 tmp2
= build_call_expr_loc (input_location
,
6520 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6521 3, dest
, src
, dlen
);
6523 /* Else copy and pad with spaces. */
6524 tmp3
= build_call_expr_loc (input_location
,
6525 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6526 3, dest
, src
, slen
);
6528 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6529 tmp4
= fill_with_spaces (tmp4
, chartype
,
6530 fold_build2_loc (input_location
, MINUS_EXPR
,
6531 TREE_TYPE(dlen
), dlen
, slen
));
6533 gfc_init_block (&tempblock
);
6534 gfc_add_expr_to_block (&tempblock
, tmp3
);
6535 gfc_add_expr_to_block (&tempblock
, tmp4
);
6536 tmp3
= gfc_finish_block (&tempblock
);
6538 /* The whole copy_string function is there. */
6539 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6541 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6542 build_empty_stmt (input_location
));
6543 gfc_add_expr_to_block (block
, tmp
);
6547 /* Translate a statement function.
6548 The value of a statement function reference is obtained by evaluating the
6549 expression using the values of the actual arguments for the values of the
6550 corresponding dummy arguments. */
6553 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6557 gfc_formal_arglist
*fargs
;
6558 gfc_actual_arglist
*args
;
6561 gfc_saved_var
*saved_vars
;
6567 sym
= expr
->symtree
->n
.sym
;
6568 args
= expr
->value
.function
.actual
;
6569 gfc_init_se (&lse
, NULL
);
6570 gfc_init_se (&rse
, NULL
);
6573 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6575 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6576 temp_vars
= XCNEWVEC (tree
, n
);
6578 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6579 fargs
= fargs
->next
, n
++)
6581 /* Each dummy shall be specified, explicitly or implicitly, to be
6583 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6586 if (fsym
->ts
.type
== BT_CHARACTER
)
6588 /* Copy string arguments. */
6591 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6592 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6594 /* Create a temporary to hold the value. */
6595 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6596 fsym
->ts
.u
.cl
->backend_decl
6597 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6599 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6600 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6602 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6604 gfc_conv_expr (&rse
, args
->expr
);
6605 gfc_conv_string_parameter (&rse
);
6606 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6607 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6609 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6610 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6611 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6612 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6616 /* For everything else, just evaluate the expression. */
6618 /* Create a temporary to hold the value. */
6619 type
= gfc_typenode_for_spec (&fsym
->ts
);
6620 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6622 gfc_conv_expr (&lse
, args
->expr
);
6624 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6625 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6626 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6632 /* Use the temporary variables in place of the real ones. */
6633 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6634 fargs
= fargs
->next
, n
++)
6635 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6637 gfc_conv_expr (se
, sym
->value
);
6639 if (sym
->ts
.type
== BT_CHARACTER
)
6641 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6643 /* Force the expression to the correct length. */
6644 if (!INTEGER_CST_P (se
->string_length
)
6645 || tree_int_cst_lt (se
->string_length
,
6646 sym
->ts
.u
.cl
->backend_decl
))
6648 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6649 tmp
= gfc_create_var (type
, sym
->name
);
6650 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6651 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6652 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6656 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6659 /* Restore the original variables. */
6660 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6661 fargs
= fargs
->next
, n
++)
6662 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6668 /* Translate a function expression. */
6671 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6675 if (expr
->value
.function
.isym
)
6677 gfc_conv_intrinsic_function (se
, expr
);
6681 /* expr.value.function.esym is the resolved (specific) function symbol for
6682 most functions. However this isn't set for dummy procedures. */
6683 sym
= expr
->value
.function
.esym
;
6685 sym
= expr
->symtree
->n
.sym
;
6687 /* The IEEE_ARITHMETIC functions are caught here. */
6688 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6689 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6692 /* We distinguish statement functions from general functions to improve
6693 runtime performance. */
6694 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6696 gfc_conv_statement_function (se
, expr
);
6700 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6705 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6708 is_zero_initializer_p (gfc_expr
* expr
)
6710 if (expr
->expr_type
!= EXPR_CONSTANT
)
6713 /* We ignore constants with prescribed memory representations for now. */
6714 if (expr
->representation
.string
)
6717 switch (expr
->ts
.type
)
6720 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6723 return mpfr_zero_p (expr
->value
.real
)
6724 && MPFR_SIGN (expr
->value
.real
) >= 0;
6727 return expr
->value
.logical
== 0;
6730 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6731 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6732 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6733 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6743 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6748 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6749 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6751 gfc_conv_tmp_array_ref (se
);
6755 /* Build a static initializer. EXPR is the expression for the initial value.
6756 The other parameters describe the variable of the component being
6757 initialized. EXPR may be null. */
6760 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6761 bool array
, bool pointer
, bool procptr
)
6765 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6766 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6767 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6768 return build_constructor (type
, NULL
);
6770 if (!(expr
|| pointer
|| procptr
))
6773 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6774 (these are the only two iso_c_binding derived types that can be
6775 used as initialization expressions). If so, we need to modify
6776 the 'expr' to be that for a (void *). */
6777 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6778 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6780 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6782 /* The derived symbol has already been converted to a (void *). Use
6784 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6785 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6787 gfc_init_se (&se
, NULL
);
6788 gfc_conv_constant (&se
, expr
);
6789 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6793 if (array
&& !procptr
)
6796 /* Arrays need special handling. */
6798 ctor
= gfc_build_null_descriptor (type
);
6799 /* Special case assigning an array to zero. */
6800 else if (is_zero_initializer_p (expr
))
6801 ctor
= build_constructor (type
, NULL
);
6803 ctor
= gfc_conv_array_initializer (type
, expr
);
6804 TREE_STATIC (ctor
) = 1;
6807 else if (pointer
|| procptr
)
6809 if (ts
->type
== BT_CLASS
&& !procptr
)
6811 gfc_init_se (&se
, NULL
);
6812 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6813 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6814 TREE_STATIC (se
.expr
) = 1;
6817 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6818 return fold_convert (type
, null_pointer_node
);
6821 gfc_init_se (&se
, NULL
);
6822 se
.want_pointer
= 1;
6823 gfc_conv_expr (&se
, expr
);
6824 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6834 gfc_init_se (&se
, NULL
);
6835 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6836 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6838 gfc_conv_structure (&se
, expr
, 1);
6839 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6840 TREE_STATIC (se
.expr
) = 1;
6845 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6846 TREE_STATIC (ctor
) = 1;
6851 gfc_init_se (&se
, NULL
);
6852 gfc_conv_constant (&se
, expr
);
6853 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6860 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6866 gfc_array_info
*lss_array
;
6873 gfc_start_block (&block
);
6875 /* Initialize the scalarizer. */
6876 gfc_init_loopinfo (&loop
);
6878 gfc_init_se (&lse
, NULL
);
6879 gfc_init_se (&rse
, NULL
);
6882 rss
= gfc_walk_expr (expr
);
6883 if (rss
== gfc_ss_terminator
)
6884 /* The rhs is scalar. Add a ss for the expression. */
6885 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6887 /* Create a SS for the destination. */
6888 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6890 lss_array
= &lss
->info
->data
.array
;
6891 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6892 lss_array
->descriptor
= dest
;
6893 lss_array
->data
= gfc_conv_array_data (dest
);
6894 lss_array
->offset
= gfc_conv_array_offset (dest
);
6895 for (n
= 0; n
< cm
->as
->rank
; n
++)
6897 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6898 lss_array
->stride
[n
] = gfc_index_one_node
;
6900 mpz_init (lss_array
->shape
[n
]);
6901 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6902 cm
->as
->lower
[n
]->value
.integer
);
6903 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6906 /* Associate the SS with the loop. */
6907 gfc_add_ss_to_loop (&loop
, lss
);
6908 gfc_add_ss_to_loop (&loop
, rss
);
6910 /* Calculate the bounds of the scalarization. */
6911 gfc_conv_ss_startstride (&loop
);
6913 /* Setup the scalarizing loops. */
6914 gfc_conv_loop_setup (&loop
, &expr
->where
);
6916 /* Setup the gfc_se structures. */
6917 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6918 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6921 gfc_mark_ss_chain_used (rss
, 1);
6923 gfc_mark_ss_chain_used (lss
, 1);
6925 /* Start the scalarized loop body. */
6926 gfc_start_scalarized_body (&loop
, &body
);
6928 gfc_conv_tmp_array_ref (&lse
);
6929 if (cm
->ts
.type
== BT_CHARACTER
)
6930 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6932 gfc_conv_expr (&rse
, expr
);
6934 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6935 gfc_add_expr_to_block (&body
, tmp
);
6937 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6939 /* Generate the copying loops. */
6940 gfc_trans_scalarizing_loops (&loop
, &body
);
6942 /* Wrap the whole thing up. */
6943 gfc_add_block_to_block (&block
, &loop
.pre
);
6944 gfc_add_block_to_block (&block
, &loop
.post
);
6946 gcc_assert (lss_array
->shape
!= NULL
);
6947 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6948 gfc_cleanup_loop (&loop
);
6950 return gfc_finish_block (&block
);
6955 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6965 gfc_expr
*arg
= NULL
;
6967 gfc_start_block (&block
);
6968 gfc_init_se (&se
, NULL
);
6970 /* Get the descriptor for the expressions. */
6971 se
.want_pointer
= 0;
6972 gfc_conv_expr_descriptor (&se
, expr
);
6973 gfc_add_block_to_block (&block
, &se
.pre
);
6974 gfc_add_modify (&block
, dest
, se
.expr
);
6976 /* Deal with arrays of derived types with allocatable components. */
6977 if (gfc_bt_struct (cm
->ts
.type
)
6978 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6979 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6982 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6983 && CLASS_DATA(cm
)->attr
.allocatable
)
6985 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6986 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6991 tmp
= TREE_TYPE (dest
);
6992 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6993 tmp
, expr
->rank
, NULL_TREE
);
6997 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6998 TREE_TYPE(cm
->backend_decl
),
6999 cm
->as
->rank
, NULL_TREE
);
7001 gfc_add_expr_to_block (&block
, tmp
);
7002 gfc_add_block_to_block (&block
, &se
.post
);
7004 if (expr
->expr_type
!= EXPR_VARIABLE
)
7005 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7008 /* We need to know if the argument of a conversion function is a
7009 variable, so that the correct lower bound can be used. */
7010 if (expr
->expr_type
== EXPR_FUNCTION
7011 && expr
->value
.function
.isym
7012 && expr
->value
.function
.isym
->conversion
7013 && expr
->value
.function
.actual
->expr
7014 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7015 arg
= expr
->value
.function
.actual
->expr
;
7017 /* Obtain the array spec of full array references. */
7019 as
= gfc_get_full_arrayspec_from_expr (arg
);
7021 as
= gfc_get_full_arrayspec_from_expr (expr
);
7023 /* Shift the lbound and ubound of temporaries to being unity,
7024 rather than zero, based. Always calculate the offset. */
7025 offset
= gfc_conv_descriptor_offset_get (dest
);
7026 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7027 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7029 for (n
= 0; n
< expr
->rank
; n
++)
7034 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7035 TODO It looks as if gfc_conv_expr_descriptor should return
7036 the correct bounds and that the following should not be
7037 necessary. This would simplify gfc_conv_intrinsic_bound
7039 if (as
&& as
->lower
[n
])
7042 gfc_init_se (&lbse
, NULL
);
7043 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7044 gfc_add_block_to_block (&block
, &lbse
.pre
);
7045 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7049 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7050 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7054 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7057 lbound
= gfc_index_one_node
;
7059 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7061 /* Shift the bounds and set the offset accordingly. */
7062 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7063 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7064 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7065 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7067 gfc_conv_descriptor_ubound_set (&block
, dest
,
7068 gfc_rank_cst
[n
], tmp
);
7069 gfc_conv_descriptor_lbound_set (&block
, dest
,
7070 gfc_rank_cst
[n
], lbound
);
7072 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7073 gfc_conv_descriptor_lbound_get (dest
,
7075 gfc_conv_descriptor_stride_get (dest
,
7077 gfc_add_modify (&block
, tmp2
, tmp
);
7078 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7080 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7085 /* If a conversion expression has a null data pointer
7086 argument, nullify the allocatable component. */
7090 if (arg
->symtree
->n
.sym
->attr
.allocatable
7091 || arg
->symtree
->n
.sym
->attr
.pointer
)
7093 non_null_expr
= gfc_finish_block (&block
);
7094 gfc_start_block (&block
);
7095 gfc_conv_descriptor_data_set (&block
, dest
,
7097 null_expr
= gfc_finish_block (&block
);
7098 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7099 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
7100 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7101 return build3_v (COND_EXPR
, tmp
,
7102 null_expr
, non_null_expr
);
7106 return gfc_finish_block (&block
);
7110 /* Allocate or reallocate scalar component, as necessary. */
7113 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7123 tree lhs_cl_size
= NULL_TREE
;
7128 if (!expr2
|| expr2
->rank
)
7131 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7133 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7135 char name
[GFC_MAX_SYMBOL_LEN
+9];
7136 gfc_component
*strlen
;
7137 /* Use the rhs string length and the lhs element size. */
7138 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7139 if (!expr2
->ts
.u
.cl
->backend_decl
)
7141 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7142 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7145 size
= expr2
->ts
.u
.cl
->backend_decl
;
7147 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7149 sprintf (name
, "_%s_length", cm
->name
);
7150 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7151 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7152 gfc_charlen_type_node
,
7153 TREE_OPERAND (comp
, 0),
7154 strlen
->backend_decl
, NULL_TREE
);
7156 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7157 tmp
= TYPE_SIZE_UNIT (tmp
);
7158 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7159 TREE_TYPE (tmp
), tmp
,
7160 fold_convert (TREE_TYPE (tmp
), size
));
7162 else if (cm
->ts
.type
== BT_CLASS
)
7164 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7165 if (expr2
->ts
.type
== BT_DERIVED
)
7167 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7168 size
= TYPE_SIZE_UNIT (tmp
);
7174 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7175 gfc_add_vptr_component (e2vtab
);
7176 gfc_add_size_component (e2vtab
);
7177 gfc_init_se (&se
, NULL
);
7178 gfc_conv_expr (&se
, e2vtab
);
7179 gfc_add_block_to_block (block
, &se
.pre
);
7180 size
= fold_convert (size_type_node
, se
.expr
);
7181 gfc_free_expr (e2vtab
);
7183 size_in_bytes
= size
;
7187 /* Otherwise use the length in bytes of the rhs. */
7188 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7189 size_in_bytes
= size
;
7192 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7193 size_in_bytes
, size_one_node
);
7195 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7197 tmp
= build_call_expr_loc (input_location
,
7198 builtin_decl_explicit (BUILT_IN_CALLOC
),
7199 2, build_one_cst (size_type_node
),
7201 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7202 gfc_add_modify (block
, comp
, tmp
);
7206 tmp
= build_call_expr_loc (input_location
,
7207 builtin_decl_explicit (BUILT_IN_MALLOC
),
7209 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7210 ptr
= gfc_class_data_get (comp
);
7213 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7214 gfc_add_modify (block
, ptr
, tmp
);
7217 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7218 /* Update the lhs character length. */
7219 gfc_add_modify (block
, lhs_cl_size
, size
);
7223 /* Assign a single component of a derived type constructor. */
7226 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7227 gfc_symbol
*sym
, bool init
)
7235 gfc_start_block (&block
);
7237 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7239 /* Only care about pointers here, not about allocatables. */
7240 gfc_init_se (&se
, NULL
);
7241 /* Pointer component. */
7242 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7243 && !cm
->attr
.proc_pointer
)
7245 /* Array pointer. */
7246 if (expr
->expr_type
== EXPR_NULL
)
7247 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7250 se
.direct_byref
= 1;
7252 gfc_conv_expr_descriptor (&se
, expr
);
7253 gfc_add_block_to_block (&block
, &se
.pre
);
7254 gfc_add_block_to_block (&block
, &se
.post
);
7259 /* Scalar pointers. */
7260 se
.want_pointer
= 1;
7261 gfc_conv_expr (&se
, expr
);
7262 gfc_add_block_to_block (&block
, &se
.pre
);
7264 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7265 && expr
->symtree
->n
.sym
->attr
.dummy
)
7266 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7268 gfc_add_modify (&block
, dest
,
7269 fold_convert (TREE_TYPE (dest
), se
.expr
));
7270 gfc_add_block_to_block (&block
, &se
.post
);
7273 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7275 /* NULL initialization for CLASS components. */
7276 tmp
= gfc_trans_structure_assign (dest
,
7277 gfc_class_initializer (&cm
->ts
, expr
),
7279 gfc_add_expr_to_block (&block
, tmp
);
7281 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7282 && !cm
->attr
.proc_pointer
)
7284 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7285 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7286 else if (cm
->attr
.allocatable
)
7288 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7289 gfc_add_expr_to_block (&block
, tmp
);
7293 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7294 gfc_add_expr_to_block (&block
, tmp
);
7297 else if (cm
->ts
.type
== BT_CLASS
7298 && CLASS_DATA (cm
)->attr
.dimension
7299 && CLASS_DATA (cm
)->attr
.allocatable
7300 && expr
->ts
.type
== BT_DERIVED
)
7302 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7303 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7304 tmp
= gfc_class_vptr_get (dest
);
7305 gfc_add_modify (&block
, tmp
,
7306 fold_convert (TREE_TYPE (tmp
), vtab
));
7307 tmp
= gfc_class_data_get (dest
);
7308 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7309 gfc_add_expr_to_block (&block
, tmp
);
7311 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7313 /* NULL initialization for allocatable components. */
7314 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7315 null_pointer_node
));
7317 else if (init
&& (cm
->attr
.allocatable
7318 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7319 && expr
->ts
.type
!= BT_CLASS
)))
7321 /* Take care about non-array allocatable components here. The alloc_*
7322 routine below is motivated by the alloc_scalar_allocatable_for_
7323 assignment() routine, but with the realloc portions removed and
7325 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7330 /* The remainder of these instructions follow the if (cm->attr.pointer)
7331 if (!cm->attr.dimension) part above. */
7332 gfc_init_se (&se
, NULL
);
7333 gfc_conv_expr (&se
, expr
);
7334 gfc_add_block_to_block (&block
, &se
.pre
);
7336 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7337 && expr
->symtree
->n
.sym
->attr
.dummy
)
7338 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7340 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7342 tmp
= gfc_class_data_get (dest
);
7343 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7344 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7345 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7346 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7347 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7350 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7352 /* For deferred strings insert a memcpy. */
7353 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7356 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7357 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7359 : expr
->ts
.u
.cl
->backend_decl
);
7360 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7361 gfc_add_expr_to_block (&block
, tmp
);
7364 gfc_add_modify (&block
, tmp
,
7365 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7366 gfc_add_block_to_block (&block
, &se
.post
);
7368 else if (gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.f90_type
!= BT_VOID
)
7370 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7372 tree dealloc
= NULL_TREE
;
7373 gfc_init_se (&se
, NULL
);
7374 gfc_conv_expr (&se
, expr
);
7375 gfc_add_block_to_block (&block
, &se
.pre
);
7376 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7377 expression in a temporary variable and deallocate the allocatable
7378 components. Then we can the copy the expression to the result. */
7379 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7380 && expr
->expr_type
!= EXPR_VARIABLE
)
7382 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7383 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7386 gfc_add_modify (&block
, dest
,
7387 fold_convert (TREE_TYPE (dest
), se
.expr
));
7388 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7389 && expr
->expr_type
!= EXPR_NULL
)
7391 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7393 gfc_add_expr_to_block (&block
, tmp
);
7394 if (dealloc
!= NULL_TREE
)
7395 gfc_add_expr_to_block (&block
, dealloc
);
7397 gfc_add_block_to_block (&block
, &se
.post
);
7401 /* Nested constructors. */
7402 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7403 gfc_add_expr_to_block (&block
, tmp
);
7406 else if (gfc_deferred_strlen (cm
, &tmp
))
7410 gcc_assert (strlen
);
7411 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7413 TREE_OPERAND (dest
, 0),
7416 if (expr
->expr_type
== EXPR_NULL
)
7418 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7419 gfc_add_modify (&block
, dest
, tmp
);
7420 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7421 gfc_add_modify (&block
, strlen
, tmp
);
7426 gfc_init_se (&se
, NULL
);
7427 gfc_conv_expr (&se
, expr
);
7428 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7429 tmp
= build_call_expr_loc (input_location
,
7430 builtin_decl_explicit (BUILT_IN_MALLOC
),
7432 gfc_add_modify (&block
, dest
,
7433 fold_convert (TREE_TYPE (dest
), tmp
));
7434 gfc_add_modify (&block
, strlen
, se
.string_length
);
7435 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7436 gfc_add_expr_to_block (&block
, tmp
);
7439 else if (!cm
->attr
.artificial
)
7441 /* Scalar component (excluding deferred parameters). */
7442 gfc_init_se (&se
, NULL
);
7443 gfc_init_se (&lse
, NULL
);
7445 gfc_conv_expr (&se
, expr
);
7446 if (cm
->ts
.type
== BT_CHARACTER
)
7447 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7449 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7450 gfc_add_expr_to_block (&block
, tmp
);
7452 return gfc_finish_block (&block
);
7455 /* Assign a derived type constructor to a variable. */
7458 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7466 gfc_start_block (&block
);
7467 cm
= expr
->ts
.u
.derived
->components
;
7469 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7470 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7471 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7475 gfc_init_se (&se
, NULL
);
7476 gfc_init_se (&lse
, NULL
);
7477 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7479 gfc_add_modify (&block
, lse
.expr
,
7480 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7482 return gfc_finish_block (&block
);
7485 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7486 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7488 /* Skip absent members in default initializers. */
7489 if (!c
->expr
&& !cm
->attr
.allocatable
)
7492 field
= cm
->backend_decl
;
7493 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7494 dest
, field
, NULL_TREE
);
7497 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7498 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7503 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7504 expr
->ts
.u
.derived
, init
);
7505 gfc_add_expr_to_block (&block
, tmp
);
7507 return gfc_finish_block (&block
);
7510 /* Build an expression for a constructor. If init is nonzero then
7511 this is part of a static variable initializer. */
7514 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7521 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7523 gcc_assert (se
->ss
== NULL
);
7524 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7525 type
= gfc_typenode_for_spec (&expr
->ts
);
7529 /* Create a temporary variable and fill it in. */
7530 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7531 /* The symtree in expr is NULL, if the code to generate is for
7532 initializing the static members only. */
7533 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7534 gfc_add_expr_to_block (&se
->pre
, tmp
);
7538 /* Though unions appear to have multiple map components, they must only
7539 have a single initializer since each map overlaps. TODO: squash map
7541 if (expr
->ts
.type
== BT_UNION
)
7543 c
= gfc_constructor_first (expr
->value
.constructor
);
7544 cm
= c
->n
.component
;
7545 val
= gfc_conv_initializer (c
->expr
, &expr
->ts
,
7546 TREE_TYPE (cm
->backend_decl
),
7547 cm
->attr
.dimension
, cm
->attr
.pointer
,
7548 cm
->attr
.proc_pointer
);
7549 val
= unshare_expr_without_location (val
);
7551 /* Append it to the constructor list. */
7552 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7556 cm
= expr
->ts
.u
.derived
->components
;
7558 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7559 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7561 /* Skip absent members in default initializers and allocatable
7562 components. Although the latter have a default initializer
7563 of EXPR_NULL,... by default, the static nullify is not needed
7564 since this is done every time we come into scope. */
7565 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7568 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7569 && strcmp (cm
->name
, "_extends") == 0
7570 && cm
->initializer
->symtree
)
7574 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7575 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7576 vtab
= unshare_expr_without_location (vtab
);
7577 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7579 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7581 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7582 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7583 fold_convert (TREE_TYPE (cm
->backend_decl
),
7586 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7587 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7588 fold_convert (TREE_TYPE (cm
->backend_decl
),
7589 integer_zero_node
));
7592 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7593 TREE_TYPE (cm
->backend_decl
),
7594 cm
->attr
.dimension
, cm
->attr
.pointer
,
7595 cm
->attr
.proc_pointer
);
7596 val
= unshare_expr_without_location (val
);
7598 /* Append it to the constructor list. */
7599 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7603 se
->expr
= build_constructor (type
, v
);
7605 TREE_CONSTANT (se
->expr
) = 1;
7609 /* Translate a substring expression. */
7612 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7618 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7620 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7621 expr
->value
.character
.length
,
7622 expr
->value
.character
.string
);
7624 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7625 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7628 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7632 /* Entry point for expression translation. Evaluates a scalar quantity.
7633 EXPR is the expression to be translated, and SE is the state structure if
7634 called from within the scalarized. */
7637 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7642 if (ss
&& ss
->info
->expr
== expr
7643 && (ss
->info
->type
== GFC_SS_SCALAR
7644 || ss
->info
->type
== GFC_SS_REFERENCE
))
7646 gfc_ss_info
*ss_info
;
7649 /* Substitute a scalar expression evaluated outside the scalarization
7651 se
->expr
= ss_info
->data
.scalar
.value
;
7652 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7653 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7655 se
->string_length
= ss_info
->string_length
;
7656 gfc_advance_se_ss_chain (se
);
7660 /* We need to convert the expressions for the iso_c_binding derived types.
7661 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7662 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7663 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7664 updated to be an integer with a kind equal to the size of a (void *). */
7665 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7666 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7668 if (expr
->expr_type
== EXPR_VARIABLE
7669 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7670 || expr
->symtree
->n
.sym
->intmod_sym_id
7671 == ISOCBINDING_NULL_FUNPTR
))
7673 /* Set expr_type to EXPR_NULL, which will result in
7674 null_pointer_node being used below. */
7675 expr
->expr_type
= EXPR_NULL
;
7679 /* Update the type/kind of the expression to be what the new
7680 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7681 expr
->ts
.type
= BT_INTEGER
;
7682 expr
->ts
.f90_type
= BT_VOID
;
7683 expr
->ts
.kind
= gfc_index_integer_kind
;
7687 gfc_fix_class_refs (expr
);
7689 switch (expr
->expr_type
)
7692 gfc_conv_expr_op (se
, expr
);
7696 gfc_conv_function_expr (se
, expr
);
7700 gfc_conv_constant (se
, expr
);
7704 gfc_conv_variable (se
, expr
);
7708 se
->expr
= null_pointer_node
;
7711 case EXPR_SUBSTRING
:
7712 gfc_conv_substring_expr (se
, expr
);
7715 case EXPR_STRUCTURE
:
7716 gfc_conv_structure (se
, expr
, 0);
7720 gfc_conv_array_constructor_expr (se
, expr
);
7729 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7730 of an assignment. */
7732 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7734 gfc_conv_expr (se
, expr
);
7735 /* All numeric lvalues should have empty post chains. If not we need to
7736 figure out a way of rewriting an lvalue so that it has no post chain. */
7737 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7740 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7741 numeric expressions. Used for scalar values where inserting cleanup code
7744 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7748 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7749 gfc_conv_expr (se
, expr
);
7752 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7753 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7755 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7759 /* Helper to translate an expression and convert it to a particular type. */
7761 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7763 gfc_conv_expr_val (se
, expr
);
7764 se
->expr
= convert (type
, se
->expr
);
7768 /* Converts an expression so that it can be passed by reference. Scalar
7772 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7778 if (ss
&& ss
->info
->expr
== expr
7779 && ss
->info
->type
== GFC_SS_REFERENCE
)
7781 /* Returns a reference to the scalar evaluated outside the loop
7783 gfc_conv_expr (se
, expr
);
7785 if (expr
->ts
.type
== BT_CHARACTER
7786 && expr
->expr_type
!= EXPR_FUNCTION
)
7787 gfc_conv_string_parameter (se
);
7789 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7794 if (expr
->ts
.type
== BT_CHARACTER
)
7796 gfc_conv_expr (se
, expr
);
7797 gfc_conv_string_parameter (se
);
7801 if (expr
->expr_type
== EXPR_VARIABLE
)
7803 se
->want_pointer
= 1;
7804 gfc_conv_expr (se
, expr
);
7807 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7808 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7809 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7815 if (expr
->expr_type
== EXPR_FUNCTION
7816 && ((expr
->value
.function
.esym
7817 && expr
->value
.function
.esym
->result
->attr
.pointer
7818 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7819 || (!expr
->value
.function
.esym
&& !expr
->ref
7820 && expr
->symtree
->n
.sym
->attr
.pointer
7821 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7823 se
->want_pointer
= 1;
7824 gfc_conv_expr (se
, expr
);
7825 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7826 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7831 gfc_conv_expr (se
, expr
);
7833 /* Create a temporary var to hold the value. */
7834 if (TREE_CONSTANT (se
->expr
))
7836 tree tmp
= se
->expr
;
7837 STRIP_TYPE_NOPS (tmp
);
7838 var
= build_decl (input_location
,
7839 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7840 DECL_INITIAL (var
) = tmp
;
7841 TREE_STATIC (var
) = 1;
7846 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7847 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7849 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7851 /* Take the address of that value. */
7852 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7857 gfc_trans_pointer_assign (gfc_code
* code
)
7859 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7863 /* Generate code for a pointer assignment. */
7866 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7868 gfc_expr
*expr1_vptr
= NULL
;
7878 gfc_start_block (&block
);
7880 gfc_init_se (&lse
, NULL
);
7882 /* Check whether the expression is a scalar or not; we cannot use
7883 expr1->rank as it can be nonzero for proc pointers. */
7884 ss
= gfc_walk_expr (expr1
);
7885 scalar
= ss
== gfc_ss_terminator
;
7887 gfc_free_ss_chain (ss
);
7889 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7890 && expr2
->expr_type
!= EXPR_FUNCTION
)
7892 gfc_add_data_component (expr2
);
7893 /* The following is required as gfc_add_data_component doesn't
7894 update ts.type if there is a tailing REF_ARRAY. */
7895 expr2
->ts
.type
= BT_DERIVED
;
7900 /* Scalar pointers. */
7901 lse
.want_pointer
= 1;
7902 gfc_conv_expr (&lse
, expr1
);
7903 gfc_init_se (&rse
, NULL
);
7904 rse
.want_pointer
= 1;
7905 gfc_conv_expr (&rse
, expr2
);
7907 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7908 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7909 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7912 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7913 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7914 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7917 gfc_add_block_to_block (&block
, &lse
.pre
);
7918 gfc_add_block_to_block (&block
, &rse
.pre
);
7920 /* For string assignments to unlimited polymorphic pointers add an
7921 assignment of the string_length to the _len component of the
7923 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7924 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7925 && (expr2
->ts
.type
== BT_CHARACTER
||
7926 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7927 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7931 len_comp
= gfc_get_len_component (expr1
);
7932 gfc_init_se (&se
, NULL
);
7933 gfc_conv_expr (&se
, len_comp
);
7935 /* ptr % _len = len (str) */
7936 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7937 lse
.string_length
= se
.expr
;
7938 gfc_free_expr (len_comp
);
7941 /* Check character lengths if character expression. The test is only
7942 really added if -fbounds-check is enabled. Exclude deferred
7943 character length lefthand sides. */
7944 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7945 && !expr1
->ts
.deferred
7946 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7947 && !gfc_is_proc_ptr_comp (expr1
))
7949 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7950 gcc_assert (lse
.string_length
&& rse
.string_length
);
7951 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7952 lse
.string_length
, rse
.string_length
,
7956 /* The assignment to an deferred character length sets the string
7957 length to that of the rhs. */
7958 if (expr1
->ts
.deferred
)
7960 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7961 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7962 else if (lse
.string_length
!= NULL
)
7963 gfc_add_modify (&block
, lse
.string_length
,
7964 build_int_cst (gfc_charlen_type_node
, 0));
7967 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7968 rse
.expr
= gfc_class_data_get (rse
.expr
);
7970 gfc_add_modify (&block
, lse
.expr
,
7971 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7973 gfc_add_block_to_block (&block
, &rse
.post
);
7974 gfc_add_block_to_block (&block
, &lse
.post
);
7981 tree strlen_rhs
= NULL_TREE
;
7983 /* Array pointer. Find the last reference on the LHS and if it is an
7984 array section ref, we're dealing with bounds remapping. In this case,
7985 set it to AR_FULL so that gfc_conv_expr_descriptor does
7986 not see it and process the bounds remapping afterwards explicitly. */
7987 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7988 if (!remap
->next
&& remap
->type
== REF_ARRAY
7989 && remap
->u
.ar
.type
== AR_SECTION
)
7991 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7993 gfc_init_se (&lse
, NULL
);
7995 lse
.descriptor_only
= 1;
7996 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7997 && expr1
->ts
.type
== BT_CLASS
)
7998 expr1_vptr
= gfc_copy_expr (expr1
);
7999 gfc_conv_expr_descriptor (&lse
, expr1
);
8000 strlen_lhs
= lse
.string_length
;
8003 if (expr2
->expr_type
== EXPR_NULL
)
8005 /* Just set the data pointer to null. */
8006 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8008 else if (rank_remap
)
8010 /* If we are rank-remapping, just get the RHS's descriptor and
8011 process this later on. */
8012 gfc_init_se (&rse
, NULL
);
8013 rse
.direct_byref
= 1;
8014 rse
.byref_noassign
= 1;
8016 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8018 gfc_conv_function_expr (&rse
, expr2
);
8020 if (expr1
->ts
.type
!= BT_CLASS
)
8021 rse
.expr
= gfc_class_data_get (rse
.expr
);
8024 gfc_add_block_to_block (&block
, &rse
.pre
);
8025 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8026 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8028 gfc_add_vptr_component (expr1_vptr
);
8029 gfc_init_se (&rse
, NULL
);
8030 rse
.want_pointer
= 1;
8031 gfc_conv_expr (&rse
, expr1_vptr
);
8032 gfc_add_modify (&lse
.pre
, rse
.expr
,
8033 fold_convert (TREE_TYPE (rse
.expr
),
8034 gfc_class_vptr_get (tmp
)));
8035 rse
.expr
= gfc_class_data_get (tmp
);
8038 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8040 tree bound
[GFC_MAX_DIMENSIONS
];
8043 for (i
= 0; i
< expr2
->rank
; i
++)
8044 bound
[i
] = NULL_TREE
;
8045 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8046 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8048 GFC_ARRAY_POINTER_CONT
, false);
8049 tmp
= gfc_create_var (tmp
, "ptrtemp");
8050 rse
.descriptor_only
= 0;
8052 rse
.direct_byref
= 1;
8053 gfc_conv_expr_descriptor (&rse
, expr2
);
8054 strlen_rhs
= rse
.string_length
;
8059 gfc_conv_expr_descriptor (&rse
, expr2
);
8060 strlen_rhs
= rse
.string_length
;
8063 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8065 /* Assign directly to the LHS's descriptor. */
8066 lse
.descriptor_only
= 0;
8067 lse
.direct_byref
= 1;
8068 gfc_conv_expr_descriptor (&lse
, expr2
);
8069 strlen_rhs
= lse
.string_length
;
8071 /* If this is a subreference array pointer assignment, use the rhs
8072 descriptor element size for the lhs span. */
8073 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
8075 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
8076 gfc_init_se (&rse
, NULL
);
8077 rse
.descriptor_only
= 1;
8078 gfc_conv_expr (&rse
, expr2
);
8079 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
8080 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
8081 if (!INTEGER_CST_P (tmp
))
8082 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
8083 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
8086 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8088 gfc_init_se (&rse
, NULL
);
8089 rse
.want_pointer
= 1;
8090 gfc_conv_function_expr (&rse
, expr2
);
8091 if (expr1
->ts
.type
!= BT_CLASS
)
8093 rse
.expr
= gfc_class_data_get (rse
.expr
);
8094 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8098 gfc_add_block_to_block (&block
, &rse
.pre
);
8099 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8100 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8102 gfc_add_vptr_component (expr1_vptr
);
8103 gfc_init_se (&rse
, NULL
);
8104 rse
.want_pointer
= 1;
8105 gfc_conv_expr (&rse
, expr1_vptr
);
8106 gfc_add_modify (&lse
.pre
, rse
.expr
,
8107 fold_convert (TREE_TYPE (rse
.expr
),
8108 gfc_class_vptr_get (tmp
)));
8109 rse
.expr
= gfc_class_data_get (tmp
);
8110 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8115 /* Assign to a temporary descriptor and then copy that
8116 temporary to the pointer. */
8117 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8118 lse
.descriptor_only
= 0;
8120 lse
.direct_byref
= 1;
8121 gfc_conv_expr_descriptor (&lse
, expr2
);
8122 strlen_rhs
= lse
.string_length
;
8123 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8127 gfc_free_expr (expr1_vptr
);
8129 gfc_add_block_to_block (&block
, &lse
.pre
);
8131 gfc_add_block_to_block (&block
, &rse
.pre
);
8133 /* If we do bounds remapping, update LHS descriptor accordingly. */
8137 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8141 /* Do rank remapping. We already have the RHS's descriptor
8142 converted in rse and now have to build the correct LHS
8143 descriptor for it. */
8147 tree lbound
, ubound
;
8150 dtype
= gfc_conv_descriptor_dtype (desc
);
8151 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8152 gfc_add_modify (&block
, dtype
, tmp
);
8154 /* Copy data pointer. */
8155 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8156 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8158 /* Copy offset but adjust it such that it would correspond
8159 to a lbound of zero. */
8160 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8161 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8163 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8165 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8167 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8168 gfc_array_index_type
, stride
, lbound
);
8169 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8170 gfc_array_index_type
, offs
, tmp
);
8172 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8174 /* Set the bounds as declared for the LHS and calculate strides as
8175 well as another offset update accordingly. */
8176 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8178 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8183 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8185 /* Convert declared bounds. */
8186 gfc_init_se (&lower_se
, NULL
);
8187 gfc_init_se (&upper_se
, NULL
);
8188 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8189 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8191 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8192 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8194 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8195 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8197 lbound
= gfc_evaluate_now (lbound
, &block
);
8198 ubound
= gfc_evaluate_now (ubound
, &block
);
8200 gfc_add_block_to_block (&block
, &lower_se
.post
);
8201 gfc_add_block_to_block (&block
, &upper_se
.post
);
8203 /* Set bounds in descriptor. */
8204 gfc_conv_descriptor_lbound_set (&block
, desc
,
8205 gfc_rank_cst
[dim
], lbound
);
8206 gfc_conv_descriptor_ubound_set (&block
, desc
,
8207 gfc_rank_cst
[dim
], ubound
);
8210 stride
= gfc_evaluate_now (stride
, &block
);
8211 gfc_conv_descriptor_stride_set (&block
, desc
,
8212 gfc_rank_cst
[dim
], stride
);
8214 /* Update offset. */
8215 offs
= gfc_conv_descriptor_offset_get (desc
);
8216 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8217 gfc_array_index_type
, lbound
, stride
);
8218 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8219 gfc_array_index_type
, offs
, tmp
);
8220 offs
= gfc_evaluate_now (offs
, &block
);
8221 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8223 /* Update stride. */
8224 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8225 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8226 gfc_array_index_type
, stride
, tmp
);
8231 /* Bounds remapping. Just shift the lower bounds. */
8233 gcc_assert (expr1
->rank
== expr2
->rank
);
8235 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8239 gcc_assert (remap
->u
.ar
.start
[dim
]);
8240 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8241 gfc_init_se (&lbound_se
, NULL
);
8242 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8244 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8245 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8246 dim
, lbound_se
.expr
);
8247 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8252 /* Check string lengths if applicable. The check is only really added
8253 to the output code if -fbounds-check is enabled. */
8254 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8256 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8257 gcc_assert (strlen_lhs
&& strlen_rhs
);
8258 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8259 strlen_lhs
, strlen_rhs
, &block
);
8262 /* If rank remapping was done, check with -fcheck=bounds that
8263 the target is at least as large as the pointer. */
8264 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8270 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8271 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8273 lsize
= gfc_evaluate_now (lsize
, &block
);
8274 rsize
= gfc_evaluate_now (rsize
, &block
);
8275 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8278 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8279 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8283 gfc_add_block_to_block (&block
, &lse
.post
);
8285 gfc_add_block_to_block (&block
, &rse
.post
);
8288 return gfc_finish_block (&block
);
8292 /* Makes sure se is suitable for passing as a function string parameter. */
8293 /* TODO: Need to check all callers of this function. It may be abused. */
8296 gfc_conv_string_parameter (gfc_se
* se
)
8300 if (TREE_CODE (se
->expr
) == STRING_CST
)
8302 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8303 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8307 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8309 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8311 type
= TREE_TYPE (se
->expr
);
8312 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8316 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8318 type
= build_pointer_type (type
);
8319 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8323 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8327 /* Generate code for assignment of scalar variables. Includes character
8328 strings and derived types with allocatable components.
8329 If you know that the LHS has no allocations, set dealloc to false.
8331 DEEP_COPY has no effect if the typespec TS is not a derived type with
8332 allocatable components. Otherwise, if it is set, an explicit copy of each
8333 allocatable component is made. This is necessary as a simple copy of the
8334 whole object would copy array descriptors as is, so that the lhs's
8335 allocatable components would point to the rhs's after the assignment.
8336 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8337 necessary if the rhs is a non-pointer function, as the allocatable components
8338 are not accessible by other means than the function's result after the
8339 function has returned. It is even more subtle when temporaries are involved,
8340 as the two following examples show:
8341 1. When we evaluate an array constructor, a temporary is created. Thus
8342 there is theoretically no alias possible. However, no deep copy is
8343 made for this temporary, so that if the constructor is made of one or
8344 more variable with allocatable components, those components still point
8345 to the variable's: DEEP_COPY should be set for the assignment from the
8346 temporary to the lhs in that case.
8347 2. When assigning a scalar to an array, we evaluate the scalar value out
8348 of the loop, store it into a temporary variable, and assign from that.
8349 In that case, deep copying when assigning to the temporary would be a
8350 waste of resources; however deep copies should happen when assigning from
8351 the temporary to each array element: again DEEP_COPY should be set for
8352 the assignment from the temporary to the lhs. */
8355 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8356 bool deep_copy
, bool dealloc
)
8362 gfc_init_block (&block
);
8364 if (ts
.type
== BT_CHARACTER
)
8369 if (lse
->string_length
!= NULL_TREE
)
8371 gfc_conv_string_parameter (lse
);
8372 gfc_add_block_to_block (&block
, &lse
->pre
);
8373 llen
= lse
->string_length
;
8376 if (rse
->string_length
!= NULL_TREE
)
8378 gcc_assert (rse
->string_length
!= NULL_TREE
);
8379 gfc_conv_string_parameter (rse
);
8380 gfc_add_block_to_block (&block
, &rse
->pre
);
8381 rlen
= rse
->string_length
;
8384 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8385 rse
->expr
, ts
.kind
);
8387 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8389 tree tmp_var
= NULL_TREE
;
8392 /* Are the rhs and the lhs the same? */
8395 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8396 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8397 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8398 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8401 /* Deallocate the lhs allocated components as long as it is not
8402 the same as the rhs. This must be done following the assignment
8403 to prevent deallocating data that could be used in the rhs
8407 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8408 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8410 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8412 gfc_add_expr_to_block (&lse
->post
, tmp
);
8415 gfc_add_block_to_block (&block
, &rse
->pre
);
8416 gfc_add_block_to_block (&block
, &lse
->pre
);
8418 gfc_add_modify (&block
, lse
->expr
,
8419 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8421 /* Restore pointer address of coarray components. */
8422 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8424 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8425 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8427 gfc_add_expr_to_block (&block
, tmp
);
8430 /* Do a deep copy if the rhs is a variable, if it is not the
8434 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8435 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8437 gfc_add_expr_to_block (&block
, tmp
);
8440 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8442 gfc_add_block_to_block (&block
, &lse
->pre
);
8443 gfc_add_block_to_block (&block
, &rse
->pre
);
8444 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8445 TREE_TYPE (lse
->expr
), rse
->expr
);
8446 gfc_add_modify (&block
, lse
->expr
, tmp
);
8450 gfc_add_block_to_block (&block
, &lse
->pre
);
8451 gfc_add_block_to_block (&block
, &rse
->pre
);
8453 gfc_add_modify (&block
, lse
->expr
,
8454 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8457 gfc_add_block_to_block (&block
, &lse
->post
);
8458 gfc_add_block_to_block (&block
, &rse
->post
);
8460 return gfc_finish_block (&block
);
8464 /* There are quite a lot of restrictions on the optimisation in using an
8465 array function assign without a temporary. */
8468 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8471 bool seen_array_ref
;
8473 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8475 /* Play it safe with class functions assigned to a derived type. */
8476 if (gfc_is_alloc_class_array_function (expr2
)
8477 && expr1
->ts
.type
== BT_DERIVED
)
8480 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8481 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8484 /* Elemental functions are scalarized so that they don't need a
8485 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8486 they would need special treatment in gfc_trans_arrayfunc_assign. */
8487 if (expr2
->value
.function
.esym
!= NULL
8488 && expr2
->value
.function
.esym
->attr
.elemental
)
8491 /* Need a temporary if rhs is not FULL or a contiguous section. */
8492 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8495 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8496 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8499 /* Functions returning pointers or allocatables need temporaries. */
8500 c
= expr2
->value
.function
.esym
8501 ? (expr2
->value
.function
.esym
->attr
.pointer
8502 || expr2
->value
.function
.esym
->attr
.allocatable
)
8503 : (expr2
->symtree
->n
.sym
->attr
.pointer
8504 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8508 /* Character array functions need temporaries unless the
8509 character lengths are the same. */
8510 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8512 if (expr1
->ts
.u
.cl
->length
== NULL
8513 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8516 if (expr2
->ts
.u
.cl
->length
== NULL
8517 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8520 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8521 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8525 /* Check that no LHS component references appear during an array
8526 reference. This is needed because we do not have the means to
8527 span any arbitrary stride with an array descriptor. This check
8528 is not needed for the rhs because the function result has to be
8530 seen_array_ref
= false;
8531 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8533 if (ref
->type
== REF_ARRAY
)
8534 seen_array_ref
= true;
8535 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8539 /* Check for a dependency. */
8540 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8541 expr2
->value
.function
.esym
,
8542 expr2
->value
.function
.actual
,
8546 /* If we have reached here with an intrinsic function, we do not
8547 need a temporary except in the particular case that reallocation
8548 on assignment is active and the lhs is allocatable and a target. */
8549 if (expr2
->value
.function
.isym
)
8550 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8552 /* If the LHS is a dummy, we need a temporary if it is not
8554 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8557 /* If the lhs has been host_associated, is in common, a pointer or is
8558 a target and the function is not using a RESULT variable, aliasing
8559 can occur and a temporary is needed. */
8560 if ((sym
->attr
.host_assoc
8561 || sym
->attr
.in_common
8562 || sym
->attr
.pointer
8563 || sym
->attr
.cray_pointee
8564 || sym
->attr
.target
)
8565 && expr2
->symtree
!= NULL
8566 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8569 /* A PURE function can unconditionally be called without a temporary. */
8570 if (expr2
->value
.function
.esym
!= NULL
8571 && expr2
->value
.function
.esym
->attr
.pure
)
8574 /* Implicit_pure functions are those which could legally be declared
8576 if (expr2
->value
.function
.esym
!= NULL
8577 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8580 if (!sym
->attr
.use_assoc
8581 && !sym
->attr
.in_common
8582 && !sym
->attr
.pointer
8583 && !sym
->attr
.target
8584 && !sym
->attr
.cray_pointee
8585 && expr2
->value
.function
.esym
)
8587 /* A temporary is not needed if the function is not contained and
8588 the variable is local or host associated and not a pointer or
8590 if (!expr2
->value
.function
.esym
->attr
.contained
)
8593 /* A temporary is not needed if the lhs has never been host
8594 associated and the procedure is contained. */
8595 else if (!sym
->attr
.host_assoc
)
8598 /* A temporary is not needed if the variable is local and not
8599 a pointer, a target or a result. */
8601 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8605 /* Default to temporary use. */
8610 /* Provide the loop info so that the lhs descriptor can be built for
8611 reallocatable assignments from extrinsic function calls. */
8614 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8617 /* Signal that the function call should not be made by
8618 gfc_conv_loop_setup. */
8619 se
->ss
->is_alloc_lhs
= 1;
8620 gfc_init_loopinfo (loop
);
8621 gfc_add_ss_to_loop (loop
, *ss
);
8622 gfc_add_ss_to_loop (loop
, se
->ss
);
8623 gfc_conv_ss_startstride (loop
);
8624 gfc_conv_loop_setup (loop
, where
);
8625 gfc_copy_loopinfo_to_se (se
, loop
);
8626 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8627 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8628 se
->ss
->is_alloc_lhs
= 0;
8632 /* For assignment to a reallocatable lhs from intrinsic functions,
8633 replace the se.expr (ie. the result) with a temporary descriptor.
8634 Null the data field so that the library allocates space for the
8635 result. Free the data of the original descriptor after the function,
8636 in case it appears in an argument expression and transfer the
8637 result to the original descriptor. */
8640 fcncall_realloc_result (gfc_se
*se
, int rank
)
8649 /* Use the allocation done by the library. Substitute the lhs
8650 descriptor with a copy, whose data field is nulled.*/
8651 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8652 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8653 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8655 /* Unallocated, the descriptor does not have a dtype. */
8656 tmp
= gfc_conv_descriptor_dtype (desc
);
8657 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8659 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8660 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8661 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8663 /* Free the lhs after the function call and copy the result data to
8664 the lhs descriptor. */
8665 tmp
= gfc_conv_descriptor_data_get (desc
);
8666 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8667 boolean_type_node
, tmp
,
8668 build_int_cst (TREE_TYPE (tmp
), 0));
8669 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8670 tmp
= gfc_call_free (tmp
);
8671 gfc_add_expr_to_block (&se
->post
, tmp
);
8673 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8674 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8676 /* Check that the shapes are the same between lhs and expression. */
8677 for (n
= 0 ; n
< rank
; n
++)
8680 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8681 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8682 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8683 gfc_array_index_type
, tmp
, tmp1
);
8684 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8685 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8686 gfc_array_index_type
, tmp
, tmp1
);
8687 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8688 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8689 gfc_array_index_type
, tmp
, tmp1
);
8690 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8691 boolean_type_node
, tmp
,
8692 gfc_index_zero_node
);
8693 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8694 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8695 boolean_type_node
, tmp
,
8699 /* 'zero_cond' being true is equal to lhs not being allocated or the
8700 shapes being different. */
8701 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8703 /* Now reset the bounds returned from the function call to bounds based
8704 on the lhs lbounds, except where the lhs is not allocated or the shapes
8705 of 'variable and 'expr' are different. Set the offset accordingly. */
8706 offset
= gfc_index_zero_node
;
8707 for (n
= 0 ; n
< rank
; n
++)
8711 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8712 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8713 gfc_array_index_type
, zero_cond
,
8714 gfc_index_one_node
, lbound
);
8715 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8717 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8718 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8719 gfc_array_index_type
, tmp
, lbound
);
8720 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8721 gfc_rank_cst
[n
], lbound
);
8722 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8723 gfc_rank_cst
[n
], tmp
);
8725 /* Set stride and accumulate the offset. */
8726 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8727 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8728 gfc_rank_cst
[n
], tmp
);
8729 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8730 gfc_array_index_type
, lbound
, tmp
);
8731 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8732 gfc_array_index_type
, offset
, tmp
);
8733 offset
= gfc_evaluate_now (offset
, &se
->post
);
8736 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8741 /* Try to translate array(:) = func (...), where func is a transformational
8742 array function, without using a temporary. Returns NULL if this isn't the
8746 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8750 gfc_component
*comp
= NULL
;
8753 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8756 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8758 comp
= gfc_get_proc_ptr_comp (expr2
);
8759 gcc_assert (expr2
->value
.function
.isym
8760 || (comp
&& comp
->attr
.dimension
)
8761 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8762 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8764 gfc_init_se (&se
, NULL
);
8765 gfc_start_block (&se
.pre
);
8766 se
.want_pointer
= 1;
8768 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8770 if (expr1
->ts
.type
== BT_DERIVED
8771 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8774 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8776 gfc_add_expr_to_block (&se
.pre
, tmp
);
8779 se
.direct_byref
= 1;
8780 se
.ss
= gfc_walk_expr (expr2
);
8781 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8783 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8784 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8785 Clearly, this cannot be done for an allocatable function result, since
8786 the shape of the result is unknown and, in any case, the function must
8787 correctly take care of the reallocation internally. For intrinsic
8788 calls, the array data is freed and the library takes care of allocation.
8789 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8791 if (flag_realloc_lhs
8792 && gfc_is_reallocatable_lhs (expr1
)
8793 && !gfc_expr_attr (expr1
).codimension
8794 && !gfc_is_coindexed (expr1
)
8795 && !(expr2
->value
.function
.esym
8796 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8798 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8800 if (!expr2
->value
.function
.isym
)
8802 ss
= gfc_walk_expr (expr1
);
8803 gcc_assert (ss
!= gfc_ss_terminator
);
8805 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8806 ss
->is_alloc_lhs
= 1;
8809 fcncall_realloc_result (&se
, expr1
->rank
);
8812 gfc_conv_function_expr (&se
, expr2
);
8813 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8816 gfc_cleanup_loop (&loop
);
8818 gfc_free_ss_chain (se
.ss
);
8820 return gfc_finish_block (&se
.pre
);
8824 /* Try to efficiently translate array(:) = 0. Return NULL if this
8828 gfc_trans_zero_assign (gfc_expr
* expr
)
8830 tree dest
, len
, type
;
8834 sym
= expr
->symtree
->n
.sym
;
8835 dest
= gfc_get_symbol_decl (sym
);
8837 type
= TREE_TYPE (dest
);
8838 if (POINTER_TYPE_P (type
))
8839 type
= TREE_TYPE (type
);
8840 if (!GFC_ARRAY_TYPE_P (type
))
8843 /* Determine the length of the array. */
8844 len
= GFC_TYPE_ARRAY_SIZE (type
);
8845 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8848 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8849 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8850 fold_convert (gfc_array_index_type
, tmp
));
8852 /* If we are zeroing a local array avoid taking its address by emitting
8854 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8855 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8856 dest
, build_constructor (TREE_TYPE (dest
),
8859 /* Convert arguments to the correct types. */
8860 dest
= fold_convert (pvoid_type_node
, dest
);
8861 len
= fold_convert (size_type_node
, len
);
8863 /* Construct call to __builtin_memset. */
8864 tmp
= build_call_expr_loc (input_location
,
8865 builtin_decl_explicit (BUILT_IN_MEMSET
),
8866 3, dest
, integer_zero_node
, len
);
8867 return fold_convert (void_type_node
, tmp
);
8871 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8872 that constructs the call to __builtin_memcpy. */
8875 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8879 /* Convert arguments to the correct types. */
8880 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8881 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8883 dst
= fold_convert (pvoid_type_node
, dst
);
8885 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8886 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8888 src
= fold_convert (pvoid_type_node
, src
);
8890 len
= fold_convert (size_type_node
, len
);
8892 /* Construct call to __builtin_memcpy. */
8893 tmp
= build_call_expr_loc (input_location
,
8894 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8896 return fold_convert (void_type_node
, tmp
);
8900 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8901 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8902 source/rhs, both are gfc_full_array_ref_p which have been checked for
8906 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8908 tree dst
, dlen
, dtype
;
8909 tree src
, slen
, stype
;
8912 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8913 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8915 dtype
= TREE_TYPE (dst
);
8916 if (POINTER_TYPE_P (dtype
))
8917 dtype
= TREE_TYPE (dtype
);
8918 stype
= TREE_TYPE (src
);
8919 if (POINTER_TYPE_P (stype
))
8920 stype
= TREE_TYPE (stype
);
8922 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8925 /* Determine the lengths of the arrays. */
8926 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8927 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8929 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8930 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8931 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8933 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8934 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8936 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8937 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8938 slen
, fold_convert (gfc_array_index_type
, tmp
));
8940 /* Sanity check that they are the same. This should always be
8941 the case, as we should already have checked for conformance. */
8942 if (!tree_int_cst_equal (slen
, dlen
))
8945 return gfc_build_memcpy_call (dst
, src
, dlen
);
8949 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8950 this can't be done. EXPR1 is the destination/lhs for which
8951 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8954 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8956 unsigned HOST_WIDE_INT nelem
;
8962 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8966 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8967 dtype
= TREE_TYPE (dst
);
8968 if (POINTER_TYPE_P (dtype
))
8969 dtype
= TREE_TYPE (dtype
);
8970 if (!GFC_ARRAY_TYPE_P (dtype
))
8973 /* Determine the lengths of the array. */
8974 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8975 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8978 /* Confirm that the constructor is the same size. */
8979 if (compare_tree_int (len
, nelem
) != 0)
8982 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8983 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8984 fold_convert (gfc_array_index_type
, tmp
));
8986 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8987 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8989 stype
= TREE_TYPE (src
);
8990 if (POINTER_TYPE_P (stype
))
8991 stype
= TREE_TYPE (stype
);
8993 return gfc_build_memcpy_call (dst
, src
, len
);
8997 /* Tells whether the expression is to be treated as a variable reference. */
9000 gfc_expr_is_variable (gfc_expr
*expr
)
9003 gfc_component
*comp
;
9004 gfc_symbol
*func_ifc
;
9006 if (expr
->expr_type
== EXPR_VARIABLE
)
9009 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9012 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9013 return gfc_expr_is_variable (arg
);
9016 /* A data-pointer-returning function should be considered as a variable
9018 if (expr
->expr_type
== EXPR_FUNCTION
9019 && expr
->ref
== NULL
)
9021 if (expr
->value
.function
.isym
!= NULL
)
9024 if (expr
->value
.function
.esym
!= NULL
)
9026 func_ifc
= expr
->value
.function
.esym
;
9031 gcc_assert (expr
->symtree
);
9032 func_ifc
= expr
->symtree
->n
.sym
;
9039 comp
= gfc_get_proc_ptr_comp (expr
);
9040 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9043 func_ifc
= comp
->ts
.interface
;
9047 if (expr
->expr_type
== EXPR_COMPCALL
)
9049 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9050 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9057 gcc_assert (func_ifc
->attr
.function
9058 && func_ifc
->result
!= NULL
);
9059 return func_ifc
->result
->attr
.pointer
;
9063 /* Is the lhs OK for automatic reallocation? */
9066 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9070 /* An allocatable variable with no reference. */
9071 if (expr
->symtree
->n
.sym
->attr
.allocatable
9075 /* All that can be left are allocatable components. However, we do
9076 not check for allocatable components here because the expression
9077 could be an allocatable component of a pointer component. */
9078 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9079 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9082 /* Find an allocatable component ref last. */
9083 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9084 if (ref
->type
== REF_COMPONENT
9086 && ref
->u
.c
.component
->attr
.allocatable
)
9093 /* Allocate or reallocate scalar lhs, as necessary. */
9096 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9111 if (!expr1
|| expr1
->rank
)
9114 if (!expr2
|| expr2
->rank
)
9117 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9118 if (ref
->type
== REF_SUBSTRING
)
9121 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9123 /* Since this is a scalar lhs, we can afford to do this. That is,
9124 there is no risk of side effects being repeated. */
9125 gfc_init_se (&lse
, NULL
);
9126 lse
.want_pointer
= 1;
9127 gfc_conv_expr (&lse
, expr1
);
9129 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9130 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9132 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9133 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9134 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9136 tmp
= build3_v (COND_EXPR
, cond
,
9137 build1_v (GOTO_EXPR
, jump_label1
),
9138 build_empty_stmt (input_location
));
9139 gfc_add_expr_to_block (block
, tmp
);
9141 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9143 /* Use the rhs string length and the lhs element size. */
9144 size
= string_length
;
9145 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9146 tmp
= TYPE_SIZE_UNIT (tmp
);
9147 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9148 TREE_TYPE (tmp
), tmp
,
9149 fold_convert (TREE_TYPE (tmp
), size
));
9153 /* Otherwise use the length in bytes of the rhs. */
9154 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9155 size_in_bytes
= size
;
9158 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9159 size_in_bytes
, size_one_node
);
9161 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9163 tree caf_decl
, token
;
9165 symbol_attribute attr
;
9167 gfc_clear_attr (&attr
);
9168 gfc_init_se (&caf_se
, NULL
);
9170 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9171 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9173 gfc_add_block_to_block (block
, &caf_se
.pre
);
9174 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9175 gfc_build_addr_expr (NULL_TREE
, token
),
9176 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9179 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9181 tmp
= build_call_expr_loc (input_location
,
9182 builtin_decl_explicit (BUILT_IN_CALLOC
),
9183 2, build_one_cst (size_type_node
),
9185 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9186 gfc_add_modify (block
, lse
.expr
, tmp
);
9190 tmp
= build_call_expr_loc (input_location
,
9191 builtin_decl_explicit (BUILT_IN_MALLOC
),
9193 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9194 gfc_add_modify (block
, lse
.expr
, tmp
);
9197 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9199 /* Deferred characters need checking for lhs and rhs string
9200 length. Other deferred parameter variables will have to
9202 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9203 gfc_add_expr_to_block (block
, tmp
);
9205 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9206 gfc_add_expr_to_block (block
, tmp
);
9208 /* For a deferred length character, reallocate if lengths of lhs and
9209 rhs are different. */
9210 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9212 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9213 lse
.string_length
, size
);
9214 /* Jump past the realloc if the lengths are the same. */
9215 tmp
= build3_v (COND_EXPR
, cond
,
9216 build1_v (GOTO_EXPR
, jump_label2
),
9217 build_empty_stmt (input_location
));
9218 gfc_add_expr_to_block (block
, tmp
);
9219 tmp
= build_call_expr_loc (input_location
,
9220 builtin_decl_explicit (BUILT_IN_REALLOC
),
9221 2, fold_convert (pvoid_type_node
, lse
.expr
),
9223 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9224 gfc_add_modify (block
, lse
.expr
, tmp
);
9225 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9226 gfc_add_expr_to_block (block
, tmp
);
9228 /* Update the lhs character length. */
9229 size
= string_length
;
9230 gfc_add_modify (block
, lse
.string_length
, size
);
9234 /* Check for assignments of the type
9238 to make sure we do not check for reallocation unneccessarily. */
9242 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9244 gfc_actual_arglist
*a
;
9247 switch (expr2
->expr_type
)
9250 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9253 if (expr2
->value
.function
.esym
9254 && expr2
->value
.function
.esym
->attr
.elemental
)
9256 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9259 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9264 else if (expr2
->value
.function
.isym
9265 && expr2
->value
.function
.isym
->elemental
)
9267 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9270 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9279 switch (expr2
->value
.op
.op
)
9282 case INTRINSIC_UPLUS
:
9283 case INTRINSIC_UMINUS
:
9284 case INTRINSIC_PARENTHESES
:
9285 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9287 case INTRINSIC_PLUS
:
9288 case INTRINSIC_MINUS
:
9289 case INTRINSIC_TIMES
:
9290 case INTRINSIC_DIVIDE
:
9291 case INTRINSIC_POWER
:
9295 case INTRINSIC_NEQV
:
9302 case INTRINSIC_EQ_OS
:
9303 case INTRINSIC_NE_OS
:
9304 case INTRINSIC_GT_OS
:
9305 case INTRINSIC_GE_OS
:
9306 case INTRINSIC_LT_OS
:
9307 case INTRINSIC_LE_OS
:
9309 e1
= expr2
->value
.op
.op1
;
9310 e2
= expr2
->value
.op
.op2
;
9312 if (e1
->rank
== 0 && e2
->rank
> 0)
9313 return is_runtime_conformable (expr1
, e2
);
9314 else if (e1
->rank
> 0 && e2
->rank
== 0)
9315 return is_runtime_conformable (expr1
, e1
);
9316 else if (e1
->rank
> 0 && e2
->rank
> 0)
9317 return is_runtime_conformable (expr1
, e1
)
9318 && is_runtime_conformable (expr1
, e2
);
9334 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9335 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9336 init_flag indicates initialization expressions and dealloc that no
9337 deallocate prior assignment is needed (if in doubt, set true). */
9340 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9346 gfc_ss
*lss_section
;
9353 bool scalar_to_array
;
9356 bool maybe_workshare
= false;
9357 symbol_attribute lhs_caf_attr
, rhs_caf_attr
;
9359 /* Assignment of the form lhs = rhs. */
9360 gfc_start_block (&block
);
9362 gfc_init_se (&lse
, NULL
);
9363 gfc_init_se (&rse
, NULL
);
9366 lss
= gfc_walk_expr (expr1
);
9367 if (gfc_is_reallocatable_lhs (expr1
)
9368 && !(expr2
->expr_type
== EXPR_FUNCTION
9369 && expr2
->value
.function
.isym
!= NULL
))
9370 lss
->is_alloc_lhs
= 1;
9373 if ((expr1
->ts
.type
== BT_DERIVED
)
9374 && (gfc_is_alloc_class_array_function (expr2
)
9375 || gfc_is_alloc_class_scalar_function (expr2
)))
9376 expr2
->must_finalize
= 1;
9378 lhs_caf_attr
= gfc_caf_attr (expr1
);
9379 rhs_caf_attr
= gfc_caf_attr (expr2
);
9381 if (lss
!= gfc_ss_terminator
)
9383 /* The assignment needs scalarization. */
9386 /* Find a non-scalar SS from the lhs. */
9387 while (lss_section
!= gfc_ss_terminator
9388 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9389 lss_section
= lss_section
->next
;
9391 gcc_assert (lss_section
!= gfc_ss_terminator
);
9393 /* Initialize the scalarizer. */
9394 gfc_init_loopinfo (&loop
);
9397 rss
= gfc_walk_expr (expr2
);
9398 if (rss
== gfc_ss_terminator
)
9399 /* The rhs is scalar. Add a ss for the expression. */
9400 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9402 /* Associate the SS with the loop. */
9403 gfc_add_ss_to_loop (&loop
, lss
);
9404 gfc_add_ss_to_loop (&loop
, rss
);
9406 /* Calculate the bounds of the scalarization. */
9407 gfc_conv_ss_startstride (&loop
);
9408 /* Enable loop reversal. */
9409 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9410 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9411 /* Resolve any data dependencies in the statement. */
9412 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9413 /* Setup the scalarizing loops. */
9414 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9416 /* Setup the gfc_se structures. */
9417 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9418 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9421 gfc_mark_ss_chain_used (rss
, 1);
9422 if (loop
.temp_ss
== NULL
)
9425 gfc_mark_ss_chain_used (lss
, 1);
9429 lse
.ss
= loop
.temp_ss
;
9430 gfc_mark_ss_chain_used (lss
, 3);
9431 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9434 /* Allow the scalarizer to workshare array assignments. */
9435 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
9436 == OMPWS_WORKSHARE_FLAG
9437 && loop
.temp_ss
== NULL
)
9439 maybe_workshare
= true;
9440 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
9443 /* Start the scalarized loop body. */
9444 gfc_start_scalarized_body (&loop
, &body
);
9447 gfc_init_block (&body
);
9449 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9451 /* Translate the expression. */
9452 gfc_conv_expr (&rse
, expr2
);
9454 /* Deal with the case of a scalar class function assigned to a derived type. */
9455 if (gfc_is_alloc_class_scalar_function (expr2
)
9456 && expr1
->ts
.type
== BT_DERIVED
)
9458 rse
.expr
= gfc_class_data_get (rse
.expr
);
9459 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9462 /* Stabilize a string length for temporaries. */
9463 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
9464 && !(TREE_CODE (rse
.string_length
) == VAR_DECL
9465 || TREE_CODE (rse
.string_length
) == PARM_DECL
9466 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
9467 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9468 else if (expr2
->ts
.type
== BT_CHARACTER
)
9469 string_length
= rse
.string_length
;
9471 string_length
= NULL_TREE
;
9475 gfc_conv_tmp_array_ref (&lse
);
9476 if (expr2
->ts
.type
== BT_CHARACTER
)
9477 lse
.string_length
= string_length
;
9481 gfc_conv_expr (&lse
, expr1
);
9482 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
9484 && gfc_expr_attr (expr1
).allocatable
9491 /* We should only get array references here. */
9492 gcc_assert (TREE_CODE (lse
.expr
) == POINTER_PLUS_EXPR
9493 || TREE_CODE (lse
.expr
) == ARRAY_REF
);
9495 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
9496 or the array itself(ARRAY_REF). */
9497 tmp
= TREE_OPERAND (lse
.expr
, 0);
9499 /* Provide the address of the array. */
9500 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
9501 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9503 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9504 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9505 msg
= _("Assignment of scalar to unallocated array");
9506 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
9507 &expr1
->where
, msg
);
9511 /* Assignments of scalar derived types with allocatable components
9512 to arrays must be done with a deep copy and the rhs temporary
9513 must have its components deallocated afterwards. */
9514 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9515 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9516 && !gfc_expr_is_variable (expr2
)
9517 && expr1
->rank
&& !expr2
->rank
);
9518 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9520 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9521 && gfc_is_alloc_class_scalar_function (expr2
));
9522 if (scalar_to_array
&& dealloc
)
9524 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9525 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9528 /* When assigning a character function result to a deferred-length variable,
9529 the function call must happen before the (re)allocation of the lhs -
9530 otherwise the character length of the result is not known.
9531 NOTE: This relies on having the exact dependence of the length type
9532 parameter available to the caller; gfortran saves it in the .mod files.
9533 NOTE ALSO: The concatenation operation generates a temporary pointer,
9534 whose allocation must go to the innermost loop. */
9535 if (flag_realloc_lhs
9536 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
9537 && !(lss
!= gfc_ss_terminator
9538 && expr2
->expr_type
== EXPR_OP
9539 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))
9540 gfc_add_block_to_block (&block
, &rse
.pre
);
9542 /* Nullify the allocatable components corresponding to those of the lhs
9543 derived type, so that the finalization of the function result does not
9544 affect the lhs of the assignment. Prepend is used to ensure that the
9545 nullification occurs before the call to the finalizer. In the case of
9546 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9547 as part of the deep copy. */
9548 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9549 && (gfc_is_alloc_class_array_function (expr2
)
9550 || gfc_is_alloc_class_scalar_function (expr2
)))
9553 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9554 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9555 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9556 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9559 if (flag_coarray
== GFC_FCOARRAY_LIB
9560 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
9561 && lhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.alloc_comp
)
9564 gfc_actual_arglist a1
, a2
;
9569 code
.ext
.actual
= &a1
;
9570 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9571 tmp
= gfc_conv_intrinsic_subroutine (&code
);
9574 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9575 gfc_expr_is_variable (expr2
)
9577 || expr2
->expr_type
== EXPR_ARRAY
,
9578 !(l_is_temp
|| init_flag
) && dealloc
);
9579 gfc_add_expr_to_block (&body
, tmp
);
9581 if (lss
== gfc_ss_terminator
)
9583 /* F2003: Add the code for reallocation on assignment. */
9584 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9585 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9588 /* Use the scalar assignment as is. */
9589 gfc_add_block_to_block (&block
, &body
);
9593 gcc_assert (lse
.ss
== gfc_ss_terminator
9594 && rse
.ss
== gfc_ss_terminator
);
9598 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9600 /* We need to copy the temporary to the actual lhs. */
9601 gfc_init_se (&lse
, NULL
);
9602 gfc_init_se (&rse
, NULL
);
9603 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9604 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9606 rse
.ss
= loop
.temp_ss
;
9609 gfc_conv_tmp_array_ref (&rse
);
9610 gfc_conv_expr (&lse
, expr1
);
9612 gcc_assert (lse
.ss
== gfc_ss_terminator
9613 && rse
.ss
== gfc_ss_terminator
);
9615 if (expr2
->ts
.type
== BT_CHARACTER
)
9616 rse
.string_length
= string_length
;
9618 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9620 gfc_add_expr_to_block (&body
, tmp
);
9623 /* F2003: Allocate or reallocate lhs of allocatable array. */
9624 if (flag_realloc_lhs
9625 && gfc_is_reallocatable_lhs (expr1
)
9627 && !is_runtime_conformable (expr1
, expr2
))
9629 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9630 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9631 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9632 if (tmp
!= NULL_TREE
)
9633 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9636 if (maybe_workshare
)
9637 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
9639 /* Generate the copying loops. */
9640 gfc_trans_scalarizing_loops (&loop
, &body
);
9642 /* Wrap the whole thing up. */
9643 gfc_add_block_to_block (&block
, &loop
.pre
);
9644 gfc_add_block_to_block (&block
, &loop
.post
);
9646 gfc_cleanup_loop (&loop
);
9649 return gfc_finish_block (&block
);
9653 /* Check whether EXPR is a copyable array. */
9656 copyable_array_p (gfc_expr
* expr
)
9658 if (expr
->expr_type
!= EXPR_VARIABLE
)
9661 /* First check it's an array. */
9662 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9665 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9668 /* Next check that it's of a simple enough type. */
9669 switch (expr
->ts
.type
)
9681 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9690 /* Translate an assignment. */
9693 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9698 /* Special case a single function returning an array. */
9699 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9701 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9706 /* Special case assigning an array to zero. */
9707 if (copyable_array_p (expr1
)
9708 && is_zero_initializer_p (expr2
))
9710 tmp
= gfc_trans_zero_assign (expr1
);
9715 /* Special case copying one array to another. */
9716 if (copyable_array_p (expr1
)
9717 && copyable_array_p (expr2
)
9718 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9719 && !gfc_check_dependency (expr1
, expr2
, 0))
9721 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9726 /* Special case initializing an array from a constant array constructor. */
9727 if (copyable_array_p (expr1
)
9728 && expr2
->expr_type
== EXPR_ARRAY
9729 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9731 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9736 /* Fallback to the scalarizer to generate explicit loops. */
9737 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9741 gfc_trans_init_assign (gfc_code
* code
)
9743 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9747 gfc_trans_assign (gfc_code
* code
)
9749 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);