1 /* Expression translation
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 tree desc
, type
, etype
;
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 etype
= TREE_TYPE (scalar
);
73 desc
= gfc_create_var (type
, "desc");
74 DECL_ARTIFICIAL (desc
) = 1;
76 if (CONSTANT_CLASS_P (scalar
))
79 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
80 gfc_add_modify (&se
->pre
, tmp
, scalar
);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
84 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
85 else if (TREE_TYPE (etype
) && TREE_CODE (TREE_TYPE (etype
)) == ARRAY_TYPE
)
86 etype
= TREE_TYPE (etype
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype_rank_type (0, etype
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
107 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
108 bool is_coarray
= sym
->attr
.codimension
;
109 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
110 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
114 if (ref
->type
== REF_COMPONENT
115 && (ref
->u
.c
.component
->attr
.allocatable
116 || ref
->u
.c
.component
->attr
.pointer
)
117 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
122 if (last_caf_ref
== NULL
)
125 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
127 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
128 if (comp
== NULL_TREE
&& comp_ref
)
130 gfc_init_se (&se
, outerse
);
131 gfc_free_ref_list (last_caf_ref
->next
);
132 last_caf_ref
->next
= NULL
;
133 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
134 se
.want_pointer
= comp_ref
;
135 gfc_conv_expr (&se
, caf_expr
);
136 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
138 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
139 se
.expr
= TREE_OPERAND (se
.expr
, 0);
140 gfc_free_expr (caf_expr
);
143 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
146 caf
= gfc_conv_descriptor_token (se
.expr
);
147 return gfc_build_addr_expr (NULL_TREE
, caf
);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
172 vec
<constructor_elt
, va_gc
> *init
= NULL
;
174 field
= TYPE_FIELDS (TREE_TYPE (decl
));
175 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
178 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
179 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
181 return build_constructor (TREE_TYPE (decl
), init
);
186 gfc_class_data_get (tree decl
)
189 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
190 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
191 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
193 return fold_build3_loc (input_location
, COMPONENT_REF
,
194 TREE_TYPE (data
), decl
, data
,
200 gfc_class_vptr_get (tree decl
)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
207 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
208 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
209 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
210 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
212 return fold_build3_loc (input_location
, COMPONENT_REF
,
213 TREE_TYPE (vptr
), decl
, vptr
,
219 gfc_class_len_get (tree decl
)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
226 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
227 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
228 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
229 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
231 return fold_build3_loc (input_location
, COMPONENT_REF
,
232 TREE_TYPE (len
), decl
, len
,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl
)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
248 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
249 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
250 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
251 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
253 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
254 TREE_TYPE (len
), decl
, len
,
256 : build_zero_cst (gfc_charlen_type_node
);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr
, int fieldno
)
266 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
267 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
269 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
270 TREE_TYPE (field
), vptr
, field
,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl
, int fieldno
)
283 vptr
= gfc_class_vptr_get (decl
);
284 return vptr_field_get (vptr
, fieldno
);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
303 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
304 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
305 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
306 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
307 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl
)
317 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
318 /* Always return size as an array index type. */
319 size
= fold_convert (gfc_array_index_type
, size
);
325 gfc_vptr_size_get (tree vptr
)
328 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
329 /* Always return size as an array index type. */
330 size
= fold_convert (gfc_array_index_type
, size
);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
358 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
360 /* Find the last class reference. */
363 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
365 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
368 if (ref
->type
== REF_COMPONENT
369 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
380 if (ref
->next
== NULL
)
384 /* Remove and store all subsequent references after the
388 tail
= class_ref
->next
;
389 class_ref
->next
= NULL
;
391 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
397 base_expr
= gfc_expr_to_initialize (e
);
399 /* Restore the original tail expression. */
402 gfc_free_ref_list (class_ref
->next
);
403 class_ref
->next
= tail
;
405 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
407 gfc_free_ref_list (e
->ref
);
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
417 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se
, NULL
);
427 gfc_conv_expr_descriptor (&se
, e
);
429 gfc_conv_expr (&se
, e
);
430 gfc_add_block_to_block (block
, &se
.pre
);
431 vptr
= gfc_get_vptr_from_expr (se
.expr
);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr
== NULL_TREE
)
437 if (UNLIMITED_POLY (e
))
438 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
441 /* Return the vptr to the address of the declared type. */
442 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
443 vtable
= vtab
->backend_decl
;
444 if (vtable
== NULL_TREE
)
445 vtable
= gfc_get_symbol_decl (vtab
);
446 vtable
= gfc_build_addr_expr (NULL
, vtable
);
447 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
448 gfc_add_modify (block
, vptr
, vtable
);
453 /* Reset the len for unlimited polymorphic objects. */
456 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
460 e
= gfc_find_and_cut_at_last_class_ref (expr
);
463 gfc_add_len_component (e
);
464 gfc_init_se (&se_len
, NULL
);
465 gfc_conv_expr (&se_len
, e
);
466 gfc_add_modify (block
, se_len
.expr
,
467 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
476 gfc_get_vptr_from_expr (tree expr
)
481 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
483 type
= TREE_TYPE (tmp
);
486 if (GFC_CLASS_TYPE_P (type
))
487 return gfc_class_vptr_get (tmp
);
488 if (type
!= TYPE_CANONICAL (type
))
489 type
= TYPE_CANONICAL (type
);
493 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
497 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
498 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
501 return gfc_class_vptr_get (tmp
);
508 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
511 tree tmp
, tmp2
, type
;
513 gfc_conv_descriptor_data_set (block
, lhs_desc
,
514 gfc_conv_descriptor_data_get (rhs_desc
));
515 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
516 gfc_conv_descriptor_offset_get (rhs_desc
));
518 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
519 gfc_conv_descriptor_dtype (rhs_desc
));
521 /* Assign the dimension as range-ref. */
522 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
523 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
525 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
526 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
527 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
528 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
529 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
530 gfc_add_modify (block
, tmp
, tmp2
);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
540 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
541 gfc_typespec class_ts
, tree vptr
, bool optional
,
542 bool optional_alloc_ptr
)
545 tree cond_optional
= NULL_TREE
;
552 /* The derived type needs to be converted to a temporary
554 tmp
= gfc_typenode_for_spec (&class_ts
);
555 var
= gfc_create_var (tmp
, "class");
558 ctree
= gfc_class_vptr_get (var
);
560 if (vptr
!= NULL_TREE
)
562 /* Use the dynamic vptr. */
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
571 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
573 gfc_add_modify (&parmse
->pre
, ctree
,
574 fold_convert (TREE_TYPE (ctree
), tmp
));
576 /* Now set the data field. */
577 ctree
= gfc_class_data_get (var
);
580 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
582 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
587 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
589 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse
, e
);
594 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
596 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
598 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
599 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
603 ss
= gfc_walk_expr (e
);
604 if (ss
== gfc_ss_terminator
)
607 gfc_conv_expr_reference (parmse
, e
);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts
.u
.derived
->components
->as
)
613 type
= get_scalar_to_descriptor_type (parmse
->expr
,
615 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
616 gfc_get_dtype (type
));
618 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
619 TREE_TYPE (parmse
->expr
),
620 cond_optional
, parmse
->expr
,
621 fold_convert (TREE_TYPE (parmse
->expr
),
623 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
627 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
629 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
631 fold_convert (TREE_TYPE (tmp
),
633 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
639 gfc_init_block (&block
);
643 parmse
->use_offset
= 1;
644 gfc_conv_expr_descriptor (parmse
, e
);
646 /* Detect any array references with vector subscripts. */
647 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
648 if (ref
->type
== REF_ARRAY
649 && ref
->u
.ar
.type
!= AR_ELEMENT
650 && ref
->u
.ar
.type
!= AR_FULL
)
652 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; dim
++)
653 if (ref
->u
.ar
.dimen_type
[dim
] == DIMEN_VECTOR
)
655 if (dim
< ref
->u
.ar
.dimen
)
659 /* Array references with vector subscripts and non-variable expressions
660 need be coverted to a one-based descriptor. */
661 if (ref
|| e
->expr_type
!= EXPR_VARIABLE
)
663 for (dim
= 0; dim
< e
->rank
; ++dim
)
664 gfc_conv_shift_descriptor_lbound (&block
, parmse
->expr
, dim
,
668 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
670 gcc_assert (class_ts
.u
.derived
->components
->as
->type
672 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
676 if (gfc_expr_attr (e
).codimension
)
677 parmse
->expr
= fold_build1_loc (input_location
,
681 gfc_add_modify (&block
, ctree
, parmse
->expr
);
686 tmp
= gfc_finish_block (&block
);
688 gfc_init_block (&block
);
689 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
691 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
692 gfc_finish_block (&block
));
693 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
696 gfc_add_block_to_block (&parmse
->pre
, &block
);
700 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
701 && class_ts
.u
.derived
->components
->ts
.u
.derived
702 ->attr
.unlimited_polymorphic
)
704 /* Take care about initializing the _len component correctly. */
705 ctree
= gfc_class_len_get (var
);
706 if (UNLIMITED_POLY (e
))
711 len
= gfc_copy_expr (e
);
712 gfc_add_len_component (len
);
713 gfc_init_se (&se
, NULL
);
714 gfc_conv_expr (&se
, len
);
716 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
717 cond_optional
, se
.expr
,
718 fold_convert (TREE_TYPE (se
.expr
),
724 tmp
= integer_zero_node
;
725 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
728 /* Pass the address of the class object. */
729 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
731 if (optional
&& optional_alloc_ptr
)
732 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
733 TREE_TYPE (parmse
->expr
),
734 cond_optional
, parmse
->expr
,
735 fold_convert (TREE_TYPE (parmse
->expr
),
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
745 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
746 gfc_typespec class_ts
, bool optional
)
748 tree var
, ctree
, tmp
;
753 gfc_init_block (&block
);
756 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
758 if (ref
->type
== REF_COMPONENT
759 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
763 if (class_ref
== NULL
764 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
765 tmp
= e
->symtree
->n
.sym
->backend_decl
;
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
771 ref
= class_ref
->next
;
772 class_ref
->next
= NULL
;
773 gfc_init_se (&tmpse
, NULL
);
774 gfc_conv_expr (&tmpse
, e
);
775 class_ref
->next
= ref
;
779 var
= gfc_typenode_for_spec (&class_ts
);
780 var
= gfc_create_var (var
, "class");
782 ctree
= gfc_class_vptr_get (var
);
783 gfc_add_modify (&block
, ctree
,
784 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
786 ctree
= gfc_class_data_get (var
);
787 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
788 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
790 /* Pass the address of the class object. */
791 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
795 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
798 tmp
= gfc_finish_block (&block
);
800 gfc_init_block (&block
);
801 tmp2
= gfc_class_data_get (var
);
802 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
804 tmp2
= gfc_finish_block (&block
);
806 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
808 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
811 gfc_add_block_to_block (&parmse
->pre
, &block
);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
818 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
819 gfc_typespec class_ts
)
827 /* The intrinsic type needs to be converted to a temporary
829 tmp
= gfc_typenode_for_spec (&class_ts
);
830 var
= gfc_create_var (tmp
, "class");
833 ctree
= gfc_class_vptr_get (var
);
835 vtab
= gfc_find_vtab (&e
->ts
);
837 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
838 gfc_add_modify (&parmse
->pre
, ctree
,
839 fold_convert (TREE_TYPE (ctree
), tmp
));
841 /* Now set the data field. */
842 ctree
= gfc_class_data_get (var
);
843 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse
, e
);
848 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
849 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
853 ss
= gfc_walk_expr (e
);
854 if (ss
== gfc_ss_terminator
)
857 gfc_conv_expr_reference (parmse
, e
);
858 if (class_ts
.u
.derived
->components
->as
859 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
861 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
863 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
864 TREE_TYPE (ctree
), tmp
);
867 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
868 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
873 parmse
->use_offset
= 1;
874 gfc_conv_expr_descriptor (parmse
, e
);
875 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
877 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
878 TREE_TYPE (ctree
), parmse
->expr
);
879 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
882 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
886 gcc_assert (class_ts
.type
== BT_CLASS
);
887 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
888 && class_ts
.u
.derived
->components
->ts
.u
.derived
889 ->attr
.unlimited_polymorphic
)
891 ctree
= gfc_class_len_get (var
);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e
->ts
.type
== BT_CHARACTER
)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse
->string_length
)
899 tmp
= parmse
->string_length
;
900 /* When the string_length is not yet set, then try the backend_decl of
902 else if (e
->ts
.u
.cl
->backend_decl
)
903 tmp
= e
->ts
.u
.cl
->backend_decl
;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e
, 0);
911 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
,
916 gfc_charlen_int_kind
,
918 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
919 e
->value
.character
.length
);
920 gfc_conv_const_charlen (e
->ts
.u
.cl
);
921 e
->ts
.u
.cl
->resolved
= 1;
922 tmp
= e
->ts
.u
.cl
->backend_decl
;
926 gfc_error ("Can't compute the length of the char array at %L.",
932 tmp
= integer_zero_node
;
934 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
936 else if (class_ts
.type
== BT_CLASS
937 && class_ts
.u
.derived
->components
938 && class_ts
.u
.derived
->components
->ts
.u
939 .derived
->attr
.unlimited_polymorphic
)
941 ctree
= gfc_class_len_get (var
);
942 gfc_add_modify (&parmse
->pre
, ctree
,
943 fold_convert (TREE_TYPE (ctree
),
946 /* Pass the address of the class object. */
947 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
963 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
964 bool elemental
, bool copyback
, bool optional
,
965 bool optional_alloc_ptr
)
971 tree cond
= NULL_TREE
;
972 tree slen
= NULL_TREE
;
976 bool full_array
= false;
978 gfc_init_block (&block
);
981 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
983 if (ref
->type
== REF_COMPONENT
984 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
987 if (ref
->next
== NULL
)
991 if ((ref
== NULL
|| class_ref
== ref
)
992 && !(gfc_is_class_array_function (e
) && parmse
->class_vptr
!= NULL_TREE
)
993 && (!class_ts
.u
.derived
->components
->as
994 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
997 /* Test for FULL_ARRAY. */
998 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
999 && gfc_expr_attr (e
).dimension
)
1002 gfc_is_class_array_ref (e
, &full_array
);
1004 /* The derived type needs to be converted to a temporary
1006 tmp
= gfc_typenode_for_spec (&class_ts
);
1007 var
= gfc_create_var (tmp
, "class");
1010 ctree
= gfc_class_data_get (var
);
1011 if (class_ts
.u
.derived
->components
->as
1012 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1016 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
1018 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
1019 gfc_get_dtype (type
));
1021 tmp
= gfc_class_data_get (parmse
->expr
);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1023 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1025 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
1028 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1032 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1033 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1034 TREE_TYPE (ctree
), parmse
->expr
);
1035 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1041 if (!elemental
&& full_array
&& copyback
)
1043 if (class_ts
.u
.derived
->components
->as
1044 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1047 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1048 gfc_conv_descriptor_data_get (ctree
));
1050 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1053 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1057 ctree
= gfc_class_vptr_get (var
);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1063 if (gfc_is_class_array_function (e
)
1064 && parmse
->class_vptr
!= NULL_TREE
)
1065 tmp
= parmse
->class_vptr
;
1066 else if (class_ref
== NULL
1067 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1069 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1071 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1072 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1074 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1075 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1077 slen
= build_zero_cst (size_type_node
);
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1084 ref
= class_ref
->next
;
1085 class_ref
->next
= NULL
;
1086 gfc_init_se (&tmpse
, NULL
);
1087 gfc_conv_expr (&tmpse
, e
);
1088 class_ref
->next
= ref
;
1090 slen
= tmpse
.string_length
;
1093 gcc_assert (tmp
!= NULL_TREE
);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1097 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1099 if (!(gfc_is_class_array_function (e
) && parmse
->class_vptr
))
1100 vptr
= gfc_class_vptr_get (tmp
);
1104 gfc_add_modify (&block
, ctree
,
1105 fold_convert (TREE_TYPE (ctree
), vptr
));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental
&& full_array
&& copyback
)
1110 gfc_add_modify (&parmse
->post
, vptr
,
1111 fold_convert (TREE_TYPE (vptr
), ctree
));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts
.type
== BT_CLASS
1115 && class_ts
.u
.derived
->components
1116 && class_ts
.u
.derived
->components
->ts
.u
1117 .derived
->attr
.unlimited_polymorphic
)
1119 ctree
= gfc_class_len_get (var
);
1120 if (UNLIMITED_POLY (e
))
1121 tmp
= gfc_class_len_get (tmp
);
1122 else if (e
->ts
.type
== BT_CHARACTER
)
1124 gcc_assert (slen
!= NULL_TREE
);
1128 tmp
= build_zero_cst (size_type_node
);
1129 gfc_add_modify (&parmse
->pre
, ctree
,
1130 fold_convert (TREE_TYPE (ctree
), tmp
));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental
&& full_array
&& copyback
)
1135 gfc_add_modify (&parmse
->post
, tmp
,
1136 fold_convert (TREE_TYPE (tmp
), ctree
));
1143 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1144 /* parmse->pre may contain some preparatory instructions for the
1145 temporary array descriptor. Those may only be executed when the
1146 optional argument is set, therefore add parmse->pre's instructions
1147 to block, which is later guarded by an if (optional_arg_given). */
1148 gfc_add_block_to_block (&parmse
->pre
, &block
);
1149 block
.head
= parmse
->pre
.head
;
1150 parmse
->pre
.head
= NULL_TREE
;
1151 tmp
= gfc_finish_block (&block
);
1153 if (optional_alloc_ptr
)
1154 tmp2
= build_empty_stmt (input_location
);
1157 gfc_init_block (&block
);
1159 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1160 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1161 null_pointer_node
));
1162 tmp2
= gfc_finish_block (&block
);
1165 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1167 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1170 gfc_add_block_to_block (&parmse
->pre
, &block
);
1172 /* Pass the address of the class object. */
1173 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1175 if (optional
&& optional_alloc_ptr
)
1176 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1177 TREE_TYPE (parmse
->expr
),
1179 fold_convert (TREE_TYPE (parmse
->expr
),
1180 null_pointer_node
));
1184 /* Given a class array declaration and an index, returns the address
1185 of the referenced element. */
1188 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1190 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1191 gfc_class_data_get (class_decl
);
1192 tree size
= gfc_class_vtab_size_get (class_decl
);
1193 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1194 gfc_array_index_type
,
1197 data
= gfc_conv_descriptor_data_get (data
);
1198 ptr
= fold_convert (pvoid_type_node
, data
);
1199 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1200 return fold_convert (TREE_TYPE (data
), ptr
);
1204 /* Copies one class expression to another, assuming that if either
1205 'to' or 'from' are arrays they are packed. Should 'from' be
1206 NULL_TREE, the initialization expression for 'to' is used, assuming
1207 that the _vptr is set. */
1210 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1220 vec
<tree
, va_gc
> *args
;
1225 bool is_from_desc
= false, is_to_class
= false;
1228 /* To prevent warnings on uninitialized variables. */
1229 from_len
= to_len
= NULL_TREE
;
1231 if (from
!= NULL_TREE
)
1232 fcn
= gfc_class_vtab_copy_get (from
);
1234 fcn
= gfc_class_vtab_copy_get (to
);
1236 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1238 if (from
!= NULL_TREE
)
1240 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1244 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1248 /* Check that from is a class. When the class is part of a coarray,
1249 then from is a common pointer and is to be used as is. */
1250 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1251 ? build_fold_indirect_ref (from
) : from
;
1253 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1254 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1255 ? gfc_class_data_get (from
) : from
;
1256 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1260 from_data
= gfc_class_vtab_def_init_get (to
);
1264 if (from
!= NULL_TREE
&& unlimited
)
1265 from_len
= gfc_class_len_or_zero_get (from
);
1267 from_len
= build_zero_cst (size_type_node
);
1270 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1273 to_data
= gfc_class_data_get (to
);
1275 to_len
= gfc_class_len_get (to
);
1278 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1281 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1283 stmtblock_t loopbody
;
1287 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1289 gfc_init_block (&body
);
1290 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1291 gfc_array_index_type
, nelems
,
1292 gfc_index_one_node
);
1293 nelems
= gfc_evaluate_now (tmp
, &body
);
1294 index
= gfc_create_var (gfc_array_index_type
, "S");
1298 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1299 vec_safe_push (args
, from_ref
);
1302 vec_safe_push (args
, from_data
);
1305 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1308 tmp
= gfc_conv_array_data (to
);
1309 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1310 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1311 gfc_build_array_ref (tmp
, index
, to
));
1313 vec_safe_push (args
, to_ref
);
1315 /* Add bounds check. */
1316 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1319 const char *name
= "<<unknown>>";
1323 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1325 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1326 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1327 logical_type_node
, from_len
, orig_nelems
);
1328 msg
= xasprintf ("Array bound mismatch for dimension %d "
1329 "of array '%s' (%%ld/%%ld)",
1332 gfc_trans_runtime_check (true, false, tmp
, &body
,
1333 &gfc_current_locus
, msg
,
1334 fold_convert (long_integer_type_node
, orig_nelems
),
1335 fold_convert (long_integer_type_node
, from_len
));
1340 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1342 /* Build the body of the loop. */
1343 gfc_init_block (&loopbody
);
1344 gfc_add_expr_to_block (&loopbody
, tmp
);
1346 /* Build the loop and return. */
1347 gfc_init_loopinfo (&loop
);
1349 loop
.from
[0] = gfc_index_zero_node
;
1350 loop
.loopvar
[0] = index
;
1351 loop
.to
[0] = nelems
;
1352 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1353 gfc_init_block (&ifbody
);
1354 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1355 stdcopy
= gfc_finish_block (&ifbody
);
1356 /* In initialization mode from_len is a constant zero. */
1357 if (unlimited
&& !integer_zerop (from_len
))
1359 vec_safe_push (args
, from_len
);
1360 vec_safe_push (args
, to_len
);
1361 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1362 /* Build the body of the loop. */
1363 gfc_init_block (&loopbody
);
1364 gfc_add_expr_to_block (&loopbody
, tmp
);
1366 /* Build the loop and return. */
1367 gfc_init_loopinfo (&loop
);
1369 loop
.from
[0] = gfc_index_zero_node
;
1370 loop
.loopvar
[0] = index
;
1371 loop
.to
[0] = nelems
;
1372 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1373 gfc_init_block (&ifbody
);
1374 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1375 extcopy
= gfc_finish_block (&ifbody
);
1377 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1378 logical_type_node
, from_len
,
1379 build_zero_cst (TREE_TYPE (from_len
)));
1380 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1381 void_type_node
, tmp
, extcopy
, stdcopy
);
1382 gfc_add_expr_to_block (&body
, tmp
);
1383 tmp
= gfc_finish_block (&body
);
1387 gfc_add_expr_to_block (&body
, stdcopy
);
1388 tmp
= gfc_finish_block (&body
);
1390 gfc_cleanup_loop (&loop
);
1394 gcc_assert (!is_from_desc
);
1395 vec_safe_push (args
, from_data
);
1396 vec_safe_push (args
, to_data
);
1397 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1399 /* In initialization mode from_len is a constant zero. */
1400 if (unlimited
&& !integer_zerop (from_len
))
1402 vec_safe_push (args
, from_len
);
1403 vec_safe_push (args
, to_len
);
1404 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1405 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1406 logical_type_node
, from_len
,
1407 build_zero_cst (TREE_TYPE (from_len
)));
1408 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1409 void_type_node
, tmp
, extcopy
, stdcopy
);
1415 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1416 if (from
== NULL_TREE
)
1419 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1421 from_data
, null_pointer_node
);
1422 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1423 void_type_node
, cond
,
1424 tmp
, build_empty_stmt (input_location
));
1432 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1434 gfc_actual_arglist
*actual
;
1439 actual
= gfc_get_actual_arglist ();
1440 actual
->expr
= gfc_copy_expr (rhs
);
1441 actual
->next
= gfc_get_actual_arglist ();
1442 actual
->next
->expr
= gfc_copy_expr (lhs
);
1443 ppc
= gfc_copy_expr (obj
);
1444 gfc_add_vptr_component (ppc
);
1445 gfc_add_component_ref (ppc
, "_copy");
1446 ppc_code
= gfc_get_code (EXEC_CALL
);
1447 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1448 /* Although '_copy' is set to be elemental in class.c, it is
1449 not staying that way. Find out why, sometime.... */
1450 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1451 ppc_code
->ext
.actual
= actual
;
1452 ppc_code
->expr1
= ppc
;
1453 /* Since '_copy' is elemental, the scalarizer will take care
1454 of arrays in gfc_trans_call. */
1455 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1456 gfc_free_statements (ppc_code
);
1458 if (UNLIMITED_POLY(obj
))
1460 /* Check if rhs is non-NULL. */
1462 gfc_init_se (&src
, NULL
);
1463 gfc_conv_expr (&src
, rhs
);
1464 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1465 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1466 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1467 null_pointer_node
));
1468 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1469 build_empty_stmt (input_location
));
1475 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1476 A MEMCPY is needed to copy the full data from the default initializer
1477 of the dynamic type. */
1480 gfc_trans_class_init_assign (gfc_code
*code
)
1484 gfc_se dst
,src
,memsz
;
1485 gfc_expr
*lhs
, *rhs
, *sz
;
1487 gfc_start_block (&block
);
1489 lhs
= gfc_copy_expr (code
->expr1
);
1490 gfc_add_data_component (lhs
);
1492 rhs
= gfc_copy_expr (code
->expr1
);
1493 gfc_add_vptr_component (rhs
);
1495 /* Make sure that the component backend_decls have been built, which
1496 will not have happened if the derived types concerned have not
1498 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1499 gfc_add_def_init_component (rhs
);
1500 /* The _def_init is always scalar. */
1503 if (code
->expr1
->ts
.type
== BT_CLASS
1504 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1506 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1507 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1508 gfc_add_full_array_ref (lhs
, tmparr
);
1509 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1513 sz
= gfc_copy_expr (code
->expr1
);
1514 gfc_add_vptr_component (sz
);
1515 gfc_add_size_component (sz
);
1517 gfc_init_se (&dst
, NULL
);
1518 gfc_init_se (&src
, NULL
);
1519 gfc_init_se (&memsz
, NULL
);
1520 gfc_conv_expr (&dst
, lhs
);
1521 gfc_conv_expr (&src
, rhs
);
1522 gfc_conv_expr (&memsz
, sz
);
1523 gfc_add_block_to_block (&block
, &src
.pre
);
1524 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1526 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1528 if (UNLIMITED_POLY(code
->expr1
))
1530 /* Check if _def_init is non-NULL. */
1531 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1532 logical_type_node
, src
.expr
,
1533 fold_convert (TREE_TYPE (src
.expr
),
1534 null_pointer_node
));
1535 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1536 tmp
, build_empty_stmt (input_location
));
1540 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1541 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1543 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1544 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1546 build_empty_stmt (input_location
));
1549 gfc_add_expr_to_block (&block
, tmp
);
1551 return gfc_finish_block (&block
);
1555 /* End of prototype trans-class.c */
1559 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1561 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1562 gfc_warning (OPT_Wrealloc_lhs
,
1563 "Code for reallocating the allocatable array at %L will "
1565 else if (warn_realloc_lhs_all
)
1566 gfc_warning (OPT_Wrealloc_lhs_all
,
1567 "Code for reallocating the allocatable variable at %L "
1568 "will be added", where
);
1572 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1575 /* Copy the scalarization loop variables. */
1578 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1581 dest
->loop
= src
->loop
;
1585 /* Initialize a simple expression holder.
1587 Care must be taken when multiple se are created with the same parent.
1588 The child se must be kept in sync. The easiest way is to delay creation
1589 of a child se until after after the previous se has been translated. */
1592 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1594 memset (se
, 0, sizeof (gfc_se
));
1595 gfc_init_block (&se
->pre
);
1596 gfc_init_block (&se
->post
);
1598 se
->parent
= parent
;
1601 gfc_copy_se_loopvars (se
, parent
);
1605 /* Advances to the next SS in the chain. Use this rather than setting
1606 se->ss = se->ss->next because all the parents needs to be kept in sync.
1610 gfc_advance_se_ss_chain (gfc_se
* se
)
1615 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1618 /* Walk down the parent chain. */
1621 /* Simple consistency check. */
1622 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1623 || p
->parent
->ss
->nested_ss
== p
->ss
);
1625 /* If we were in a nested loop, the next scalarized expression can be
1626 on the parent ss' next pointer. Thus we should not take the next
1627 pointer blindly, but rather go up one nest level as long as next
1628 is the end of chain. */
1630 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1640 /* Ensures the result of the expression as either a temporary variable
1641 or a constant so that it can be used repeatedly. */
1644 gfc_make_safe_expr (gfc_se
* se
)
1648 if (CONSTANT_CLASS_P (se
->expr
))
1651 /* We need a temporary for this result. */
1652 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1653 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1658 /* Return an expression which determines if a dummy parameter is present.
1659 Also used for arguments to procedures with multiple entry points. */
1662 gfc_conv_expr_present (gfc_symbol
* sym
)
1666 gcc_assert (sym
->attr
.dummy
);
1667 decl
= gfc_get_symbol_decl (sym
);
1669 /* Intrinsic scalars with VALUE attribute which are passed by value
1670 use a hidden argument to denote the present status. */
1671 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1672 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1673 && !sym
->attr
.dimension
)
1675 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1678 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1680 strcpy (&name
[1], sym
->name
);
1681 tree_name
= get_identifier (name
);
1683 /* Walk function argument list to find hidden arg. */
1684 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1685 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1686 if (DECL_NAME (cond
) == tree_name
)
1693 if (TREE_CODE (decl
) != PARM_DECL
)
1695 /* Array parameters use a temporary descriptor, we want the real
1697 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1698 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1699 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1702 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, decl
,
1703 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1705 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1706 as actual argument to denote absent dummies. For array descriptors,
1707 we thus also need to check the array descriptor. For BT_CLASS, it
1708 can also occur for scalars and F2003 due to type->class wrapping and
1709 class->class wrapping. Note further that BT_CLASS always uses an
1710 array descriptor for arrays, also for explicit-shape/assumed-size. */
1712 if (!sym
->attr
.allocatable
1713 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1714 || (sym
->ts
.type
== BT_CLASS
1715 && !CLASS_DATA (sym
)->attr
.allocatable
1716 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1717 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1718 || sym
->ts
.type
== BT_CLASS
))
1722 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1723 || sym
->as
->type
== AS_ASSUMED_RANK
1724 || sym
->attr
.codimension
))
1725 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1727 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1728 if (sym
->ts
.type
== BT_CLASS
)
1729 tmp
= gfc_class_data_get (tmp
);
1730 tmp
= gfc_conv_array_data (tmp
);
1732 else if (sym
->ts
.type
== BT_CLASS
)
1733 tmp
= gfc_class_data_get (decl
);
1737 if (tmp
!= NULL_TREE
)
1739 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
1740 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1741 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1742 logical_type_node
, cond
, tmp
);
1750 /* Converts a missing, dummy argument into a null or zero. */
1753 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1758 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1762 /* Create a temporary and convert it to the correct type. */
1763 tmp
= gfc_get_int_type (kind
);
1764 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1767 /* Test for a NULL value. */
1768 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1769 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1770 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1771 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1775 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1777 build_zero_cst (TREE_TYPE (se
->expr
)));
1778 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1782 if (ts
.type
== BT_CHARACTER
)
1784 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1785 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1786 present
, se
->string_length
, tmp
);
1787 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1788 se
->string_length
= tmp
;
1794 /* Get the character length of an expression, looking through gfc_refs
1798 gfc_get_expr_charlen (gfc_expr
*e
)
1803 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1804 && e
->ts
.type
== BT_CHARACTER
);
1806 length
= NULL
; /* To silence compiler warning. */
1808 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1811 gfc_init_se (&tmpse
, NULL
);
1812 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1813 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1817 /* First candidate: if the variable is of type CHARACTER, the
1818 expression's length could be the length of the character
1820 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1821 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1823 /* Look through the reference chain for component references. */
1824 for (r
= e
->ref
; r
; r
= r
->next
)
1829 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1830 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1838 /* We should never got substring references here. These will be
1839 broken down by the scalarizer. */
1845 gcc_assert (length
!= NULL
);
1850 /* Return for an expression the backend decl of the coarray. */
1853 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1859 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1861 /* Not-implemented diagnostic. */
1862 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1863 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1864 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1865 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1866 "%L is not supported", &expr
->where
);
1868 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1869 if (ref
->type
== REF_COMPONENT
)
1871 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1872 && UNLIMITED_POLY (ref
->u
.c
.component
)
1873 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1874 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1875 "component at %L is not supported", &expr
->where
);
1878 /* Make sure the backend_decl is present before accessing it. */
1879 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
== NULL_TREE
1880 ? gfc_get_symbol_decl (expr
->symtree
->n
.sym
)
1881 : expr
->symtree
->n
.sym
->backend_decl
;
1883 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1885 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1887 caf_decl
= gfc_class_data_get (caf_decl
);
1888 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1891 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1893 if (ref
->type
== REF_COMPONENT
1894 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1896 caf_decl
= gfc_class_data_get (caf_decl
);
1897 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1901 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1905 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1908 /* The following code assumes that the coarray is a component reachable via
1909 only scalar components/variables; the Fortran standard guarantees this. */
1911 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1912 if (ref
->type
== REF_COMPONENT
)
1914 gfc_component
*comp
= ref
->u
.c
.component
;
1916 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1917 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1918 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1919 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1920 comp
->backend_decl
, NULL_TREE
);
1921 if (comp
->ts
.type
== BT_CLASS
)
1923 caf_decl
= gfc_class_data_get (caf_decl
);
1924 if (CLASS_DATA (comp
)->attr
.codimension
)
1930 if (comp
->attr
.codimension
)
1936 gcc_assert (found
&& caf_decl
);
1941 /* Obtain the Coarray token - and optionally also the offset. */
1944 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1945 tree se_expr
, gfc_expr
*expr
)
1949 /* Coarray token. */
1950 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1952 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1953 == GFC_ARRAY_ALLOCATABLE
1954 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1955 *token
= gfc_conv_descriptor_token (caf_decl
);
1957 else if (DECL_LANG_SPECIFIC (caf_decl
)
1958 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1959 *token
= GFC_DECL_TOKEN (caf_decl
);
1962 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1963 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1964 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1970 /* Offset between the coarray base address and the address wanted. */
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1972 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1973 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1974 *offset
= build_int_cst (gfc_array_index_type
, 0);
1975 else if (DECL_LANG_SPECIFIC (caf_decl
)
1976 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1977 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1978 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1979 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1981 *offset
= build_int_cst (gfc_array_index_type
, 0);
1983 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1984 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1986 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1987 tmp
= gfc_conv_descriptor_data_get (tmp
);
1989 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1990 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1993 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1997 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1998 *offset
, fold_convert (gfc_array_index_type
, tmp
));
2000 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
2001 && expr
->symtree
->n
.sym
->attr
.codimension
2002 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
2004 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
2005 gfc_ref
*ref
= base_expr
->ref
;
2008 // Iterate through the refs until the last one.
2012 if (ref
->type
== REF_ARRAY
2013 && ref
->u
.ar
.type
!= AR_FULL
)
2015 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
2017 for (i
= 0; i
< ranksum
; ++i
)
2019 ref
->u
.ar
.start
[i
] = NULL
;
2020 ref
->u
.ar
.end
[i
] = NULL
;
2022 ref
->u
.ar
.type
= AR_FULL
;
2024 gfc_init_se (&base_se
, NULL
);
2025 if (gfc_caf_attr (base_expr
).dimension
)
2027 gfc_conv_expr_descriptor (&base_se
, base_expr
);
2028 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
2032 gfc_conv_expr (&base_se
, base_expr
);
2036 gfc_free_expr (base_expr
);
2037 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
2038 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
2040 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
2041 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
2044 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2048 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2049 fold_convert (gfc_array_index_type
, *offset
),
2050 fold_convert (gfc_array_index_type
, tmp
));
2054 /* Convert the coindex of a coarray into an image index; the result is
2055 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2056 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2059 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2062 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2066 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2067 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2069 gcc_assert (ref
!= NULL
);
2071 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2073 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2077 img_idx
= integer_zero_node
;
2078 extent
= integer_one_node
;
2079 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2080 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2082 gfc_init_se (&se
, NULL
);
2083 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2084 gfc_add_block_to_block (block
, &se
.pre
);
2085 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2086 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2087 integer_type_node
, se
.expr
,
2088 fold_convert(integer_type_node
, lbound
));
2089 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2091 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2093 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2095 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2096 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2097 tmp
= fold_convert (integer_type_node
, tmp
);
2098 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2099 integer_type_node
, extent
, tmp
);
2103 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2105 gfc_init_se (&se
, NULL
);
2106 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2107 gfc_add_block_to_block (block
, &se
.pre
);
2108 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2109 lbound
= fold_convert (integer_type_node
, lbound
);
2110 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2111 integer_type_node
, se
.expr
, lbound
);
2112 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2114 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2116 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2118 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2119 ubound
= fold_convert (integer_type_node
, ubound
);
2120 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2121 integer_type_node
, ubound
, lbound
);
2122 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2123 tmp
, integer_one_node
);
2124 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2125 integer_type_node
, extent
, tmp
);
2128 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2129 img_idx
, integer_one_node
);
2134 /* For each character array constructor subexpression without a ts.u.cl->length,
2135 replace it by its first element (if there aren't any elements, the length
2136 should already be set to zero). */
2139 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2141 gfc_actual_arglist
* arg
;
2147 switch (e
->expr_type
)
2151 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2152 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2156 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2160 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2161 flatten_array_ctors_without_strlen (arg
->expr
);
2166 /* We've found what we're looking for. */
2167 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2172 gcc_assert (e
->value
.constructor
);
2174 c
= gfc_constructor_first (e
->value
.constructor
);
2178 flatten_array_ctors_without_strlen (new_expr
);
2179 gfc_replace_expr (e
, new_expr
);
2183 /* Otherwise, fall through to handle constructor elements. */
2185 case EXPR_STRUCTURE
:
2186 for (c
= gfc_constructor_first (e
->value
.constructor
);
2187 c
; c
= gfc_constructor_next (c
))
2188 flatten_array_ctors_without_strlen (c
->expr
);
2198 /* Generate code to initialize a string length variable. Returns the
2199 value. For array constructors, cl->length might be NULL and in this case,
2200 the first element of the constructor is needed. expr is the original
2201 expression so we can access it but can be NULL if this is not needed. */
2204 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2208 gfc_init_se (&se
, NULL
);
2210 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2213 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2214 "flatten" array constructors by taking their first element; all elements
2215 should be the same length or a cl->length should be present. */
2218 gfc_expr
* expr_flat
;
2220 expr_flat
= gfc_copy_expr (expr
);
2221 flatten_array_ctors_without_strlen (expr_flat
);
2222 gfc_resolve_expr (expr_flat
);
2224 gfc_conv_expr (&se
, expr_flat
);
2225 gfc_add_block_to_block (pblock
, &se
.pre
);
2226 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2228 gfc_free_expr (expr_flat
);
2232 /* Convert cl->length. */
2234 gcc_assert (cl
->length
);
2236 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2237 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2238 se
.expr
, build_zero_cst (TREE_TYPE (se
.expr
)));
2239 gfc_add_block_to_block (pblock
, &se
.pre
);
2241 if (cl
->backend_decl
)
2242 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2244 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2249 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2250 const char *name
, locus
*where
)
2260 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2261 type
= build_pointer_type (type
);
2263 gfc_init_se (&start
, se
);
2264 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2265 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2267 if (integer_onep (start
.expr
))
2268 gfc_conv_string_parameter (se
);
2273 /* Avoid multiple evaluation of substring start. */
2274 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2275 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2277 /* Change the start of the string. */
2278 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2281 tmp
= build_fold_indirect_ref_loc (input_location
,
2283 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2284 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2287 /* Length = end + 1 - start. */
2288 gfc_init_se (&end
, se
);
2289 if (ref
->u
.ss
.end
== NULL
)
2290 end
.expr
= se
->string_length
;
2293 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2294 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2298 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2299 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2301 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2303 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2304 logical_type_node
, start
.expr
,
2307 /* Check lower bound. */
2308 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
2310 build_one_cst (TREE_TYPE (start
.expr
)));
2311 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2312 logical_type_node
, nonempty
, fault
);
2314 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2315 "is less than one", name
);
2317 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) "
2318 "is less than one");
2319 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2320 fold_convert (long_integer_type_node
,
2324 /* Check upper bound. */
2325 fault
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
2326 end
.expr
, se
->string_length
);
2327 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2328 logical_type_node
, nonempty
, fault
);
2330 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2331 "exceeds string length (%%ld)", name
);
2333 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2334 "exceeds string length (%%ld)");
2335 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2336 fold_convert (long_integer_type_node
, end
.expr
),
2337 fold_convert (long_integer_type_node
,
2338 se
->string_length
));
2342 /* Try to calculate the length from the start and end expressions. */
2344 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2346 HOST_WIDE_INT i_len
;
2348 i_len
= gfc_mpz_get_hwi (length
) + 1;
2352 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2353 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2357 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2358 fold_convert (gfc_charlen_type_node
, end
.expr
),
2359 fold_convert (gfc_charlen_type_node
, start
.expr
));
2360 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2361 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2362 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2363 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2366 se
->string_length
= tmp
;
2370 /* Convert a derived type component reference. */
2373 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2381 c
= ref
->u
.c
.component
;
2383 if (c
->backend_decl
== NULL_TREE
2384 && ref
->u
.c
.sym
!= NULL
)
2385 gfc_get_derived_type (ref
->u
.c
.sym
);
2387 field
= c
->backend_decl
;
2388 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2390 context
= DECL_FIELD_CONTEXT (field
);
2392 /* Components can correspond to fields of different containing
2393 types, as components are created without context, whereas
2394 a concrete use of a component has the type of decl as context.
2395 So, if the type doesn't match, we search the corresponding
2396 FIELD_DECL in the parent type. To not waste too much time
2397 we cache this result in norestrict_decl.
2398 On the other hand, if the context is a UNION or a MAP (a
2399 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2401 if (context
!= TREE_TYPE (decl
)
2402 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2403 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2405 tree f2
= c
->norestrict_decl
;
2406 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2407 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2408 if (TREE_CODE (f2
) == FIELD_DECL
2409 && DECL_NAME (f2
) == DECL_NAME (field
))
2412 c
->norestrict_decl
= f2
;
2416 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2417 && strcmp ("_data", c
->name
) == 0)
2419 /* Found a ref to the _data component. Store the associated ref to
2420 the vptr in se->class_vptr. */
2421 se
->class_vptr
= gfc_class_vptr_get (decl
);
2424 se
->class_vptr
= NULL_TREE
;
2426 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2427 decl
, field
, NULL_TREE
);
2431 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2432 strlen () conditional below. */
2433 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2434 && !(c
->attr
.allocatable
&& c
->ts
.deferred
)
2435 && !c
->attr
.pdt_string
)
2437 tmp
= c
->ts
.u
.cl
->backend_decl
;
2438 /* Components must always be constant length. */
2439 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2440 se
->string_length
= tmp
;
2443 if (gfc_deferred_strlen (c
, &field
))
2445 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2447 decl
, field
, NULL_TREE
);
2448 se
->string_length
= tmp
;
2451 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2452 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2453 && c
->ts
.type
!= BT_CHARACTER
)
2454 || c
->attr
.proc_pointer
)
2455 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2460 /* This function deals with component references to components of the
2461 parent type for derived type extensions. */
2463 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2471 c
= ref
->u
.c
.component
;
2473 /* Return if the component is in the parent type. */
2474 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2475 if (strcmp (c
->name
, cmp
->name
) == 0)
2478 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2479 parent
.type
= REF_COMPONENT
;
2481 parent
.u
.c
.sym
= dt
;
2482 parent
.u
.c
.component
= dt
->components
;
2484 if (dt
->backend_decl
== NULL
)
2485 gfc_get_derived_type (dt
);
2487 /* Build the reference and call self. */
2488 gfc_conv_component_ref (se
, &parent
);
2489 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2490 parent
.u
.c
.component
= c
;
2491 conv_parent_component_references (se
, &parent
);
2494 /* Return the contents of a variable. Also handles reference/pointer
2495 variables (all Fortran pointer references are implicit). */
2498 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2503 tree parent_decl
= NULL_TREE
;
2506 bool alternate_entry
;
2509 bool first_time
= true;
2511 sym
= expr
->symtree
->n
.sym
;
2512 is_classarray
= IS_CLASS_ARRAY (sym
);
2516 gfc_ss_info
*ss_info
= ss
->info
;
2518 /* Check that something hasn't gone horribly wrong. */
2519 gcc_assert (ss
!= gfc_ss_terminator
);
2520 gcc_assert (ss_info
->expr
== expr
);
2522 /* A scalarized term. We already know the descriptor. */
2523 se
->expr
= ss_info
->data
.array
.descriptor
;
2524 se
->string_length
= ss_info
->string_length
;
2525 ref
= ss_info
->data
.array
.ref
;
2527 gcc_assert (ref
->type
== REF_ARRAY
2528 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2530 gfc_conv_tmp_array_ref (se
);
2534 tree se_expr
= NULL_TREE
;
2536 se
->expr
= gfc_get_symbol_decl (sym
);
2538 /* Deal with references to a parent results or entries by storing
2539 the current_function_decl and moving to the parent_decl. */
2540 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2541 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2542 && sym
->result
== sym
;
2543 entry_master
= sym
->attr
.result
2544 && sym
->ns
->proc_name
->attr
.entry_master
2545 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2546 if (current_function_decl
)
2547 parent_decl
= DECL_CONTEXT (current_function_decl
);
2549 if ((se
->expr
== parent_decl
&& return_value
)
2550 || (sym
->ns
&& sym
->ns
->proc_name
2552 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2553 && (alternate_entry
|| entry_master
)))
2558 /* Special case for assigning the return value of a function.
2559 Self recursive functions must have an explicit return value. */
2560 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2561 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2563 /* Similarly for alternate entry points. */
2564 else if (alternate_entry
2565 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2568 gfc_entry_list
*el
= NULL
;
2570 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2573 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2578 else if (entry_master
2579 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2581 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2586 /* Procedure actual arguments. Look out for temporary variables
2587 with the same attributes as function values. */
2588 else if (!sym
->attr
.temporary
2589 && sym
->attr
.flavor
== FL_PROCEDURE
2590 && se
->expr
!= current_function_decl
)
2592 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2594 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2595 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2601 /* Dereference the expression, where needed. Since characters
2602 are entirely different from other types, they are treated
2604 if (sym
->ts
.type
== BT_CHARACTER
)
2606 /* Dereference character pointer dummy arguments
2608 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2610 || sym
->attr
.function
2611 || sym
->attr
.result
))
2612 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2616 else if (!sym
->attr
.value
)
2618 /* Dereference temporaries for class array dummy arguments. */
2619 if (sym
->attr
.dummy
&& is_classarray
2620 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2622 if (!se
->descriptor_only
)
2623 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2625 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2629 /* Dereference non-character scalar dummy arguments. */
2630 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2631 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2632 && (sym
->ts
.type
!= BT_CLASS
2633 || (!CLASS_DATA (sym
)->attr
.dimension
2634 && !(CLASS_DATA (sym
)->attr
.codimension
2635 && CLASS_DATA (sym
)->attr
.allocatable
))))
2636 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2639 /* Dereference scalar hidden result. */
2640 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2641 && (sym
->attr
.function
|| sym
->attr
.result
)
2642 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2643 && !sym
->attr
.always_explicit
)
2644 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2647 /* Dereference non-character, non-class pointer variables.
2648 These must be dummies, results, or scalars. */
2650 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2651 || gfc_is_associate_pointer (sym
)
2652 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2654 || sym
->attr
.function
2656 || (!sym
->attr
.dimension
2657 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2658 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2660 /* Now treat the class array pointer variables accordingly. */
2661 else if (sym
->ts
.type
== BT_CLASS
2663 && (CLASS_DATA (sym
)->attr
.dimension
2664 || CLASS_DATA (sym
)->attr
.codimension
)
2665 && ((CLASS_DATA (sym
)->as
2666 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2667 || CLASS_DATA (sym
)->attr
.allocatable
2668 || CLASS_DATA (sym
)->attr
.class_pointer
))
2669 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2671 /* And the case where a non-dummy, non-result, non-function,
2672 non-allotable and non-pointer classarray is present. This case was
2673 previously covered by the first if, but with introducing the
2674 condition !is_classarray there, that case has to be covered
2676 else if (sym
->ts
.type
== BT_CLASS
2678 && !sym
->attr
.function
2679 && !sym
->attr
.result
2680 && (CLASS_DATA (sym
)->attr
.dimension
2681 || CLASS_DATA (sym
)->attr
.codimension
)
2683 || !CLASS_DATA (sym
)->attr
.allocatable
)
2684 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2685 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2692 /* For character variables, also get the length. */
2693 if (sym
->ts
.type
== BT_CHARACTER
)
2695 /* If the character length of an entry isn't set, get the length from
2696 the master function instead. */
2697 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2698 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2700 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2701 gcc_assert (se
->string_length
);
2709 /* Return the descriptor if that's what we want and this is an array
2710 section reference. */
2711 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2713 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2714 /* Return the descriptor for array pointers and allocations. */
2715 if (se
->want_pointer
2716 && ref
->next
== NULL
&& (se
->descriptor_only
))
2719 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2720 /* Return a pointer to an element. */
2724 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2725 && se
->descriptor_only
2726 && !CLASS_DATA (sym
)->attr
.allocatable
2727 && !CLASS_DATA (sym
)->attr
.class_pointer
2728 && CLASS_DATA (sym
)->as
2729 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2730 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2731 /* Skip the first ref of a _data component, because for class
2732 arrays that one is already done by introducing a temporary
2733 array descriptor. */
2736 if (ref
->u
.c
.sym
->attr
.extension
)
2737 conv_parent_component_references (se
, ref
);
2739 gfc_conv_component_ref (se
, ref
);
2740 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2741 && se
->want_pointer
&& se
->descriptor_only
)
2747 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2748 expr
->symtree
->name
, &expr
->where
);
2758 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2760 if (se
->want_pointer
)
2762 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2763 gfc_conv_string_parameter (se
);
2765 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2770 /* Unary ops are easy... Or they would be if ! was a valid op. */
2773 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2778 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2779 /* Initialize the operand. */
2780 gfc_init_se (&operand
, se
);
2781 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2782 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2784 type
= gfc_typenode_for_spec (&expr
->ts
);
2786 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2787 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2788 All other unary operators have an equivalent GIMPLE unary operator. */
2789 if (code
== TRUTH_NOT_EXPR
)
2790 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2791 build_int_cst (type
, 0));
2793 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2797 /* Expand power operator to optimal multiplications when a value is raised
2798 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2799 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2800 Programming", 3rd Edition, 1998. */
2802 /* This code is mostly duplicated from expand_powi in the backend.
2803 We establish the "optimal power tree" lookup table with the defined size.
2804 The items in the table are the exponents used to calculate the index
2805 exponents. Any integer n less than the value can get an "addition chain",
2806 with the first node being one. */
2807 #define POWI_TABLE_SIZE 256
2809 /* The table is from builtins.c. */
2810 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2812 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2813 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2814 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2815 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2816 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2817 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2818 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2819 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2820 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2821 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2822 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2823 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2824 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2825 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2826 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2827 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2828 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2829 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2830 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2831 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2832 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2833 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2834 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2835 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2836 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2837 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2838 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2839 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2840 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2841 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2842 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2843 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2846 /* If n is larger than lookup table's max index, we use the "window
2848 #define POWI_WINDOW_SIZE 3
2850 /* Recursive function to expand the power operator. The temporary
2851 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2853 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2860 if (n
< POWI_TABLE_SIZE
)
2865 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2866 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2870 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2871 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2872 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2876 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2880 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2881 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2883 if (n
< POWI_TABLE_SIZE
)
2890 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2891 return 1. Else return 0 and a call to runtime library functions
2892 will have to be built. */
2894 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2899 tree vartmp
[POWI_TABLE_SIZE
];
2901 unsigned HOST_WIDE_INT n
;
2903 wi::tree_to_wide_ref wrhs
= wi::to_wide (rhs
);
2905 /* If exponent is too large, we won't expand it anyway, so don't bother
2906 with large integer values. */
2907 if (!wi::fits_shwi_p (wrhs
))
2910 m
= wrhs
.to_shwi ();
2911 /* Use the wide_int's routine to reliably get the absolute value on all
2912 platforms. Then convert it to a HOST_WIDE_INT like above. */
2913 n
= wi::abs (wrhs
).to_shwi ();
2915 type
= TREE_TYPE (lhs
);
2916 sgn
= tree_int_cst_sgn (rhs
);
2918 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2919 || optimize_size
) && (m
> 2 || m
< -1))
2925 se
->expr
= gfc_build_const (type
, integer_one_node
);
2929 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2930 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2932 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2933 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2934 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
2935 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2938 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2941 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2942 logical_type_node
, tmp
, cond
);
2943 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2944 tmp
, build_int_cst (type
, 1),
2945 build_int_cst (type
, 0));
2949 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2950 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2951 build_int_cst (type
, -1),
2952 build_int_cst (type
, 0));
2953 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2954 cond
, build_int_cst (type
, 1), tmp
);
2958 memset (vartmp
, 0, sizeof (vartmp
));
2962 tmp
= gfc_build_const (type
, integer_one_node
);
2963 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2967 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2973 /* Power op (**). Constant integer exponent has special handling. */
2976 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2978 tree gfc_int4_type_node
;
2981 int res_ikind_1
, res_ikind_2
;
2986 gfc_init_se (&lse
, se
);
2987 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2988 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2989 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2991 gfc_init_se (&rse
, se
);
2992 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2993 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2995 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2996 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2997 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
3000 gfc_int4_type_node
= gfc_get_int_type (4);
3002 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3003 library routine. But in the end, we have to convert the result back
3004 if this case applies -- with res_ikind_K, we keep track whether operand K
3005 falls into this case. */
3009 kind
= expr
->value
.op
.op1
->ts
.kind
;
3010 switch (expr
->value
.op
.op2
->ts
.type
)
3013 ikind
= expr
->value
.op
.op2
->ts
.kind
;
3018 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
3019 res_ikind_2
= ikind
;
3041 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
3043 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3070 switch (expr
->value
.op
.op1
->ts
.type
)
3073 if (kind
== 3) /* Case 16 was not handled properly above. */
3075 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3079 /* Use builtins for real ** int4. */
3085 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3089 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3093 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3097 /* Use the __builtin_powil() only if real(kind=16) is
3098 actually the C long double type. */
3099 if (!gfc_real16_is_float128
)
3100 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3108 /* If we don't have a good builtin for this, go for the
3109 library function. */
3111 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3115 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3124 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3128 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3136 se
->expr
= build_call_expr_loc (input_location
,
3137 fndecl
, 2, lse
.expr
, rse
.expr
);
3139 /* Convert the result back if it is of wrong integer kind. */
3140 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3142 /* We want the maximum of both operand kinds as result. */
3143 if (res_ikind_1
< res_ikind_2
)
3144 res_ikind_1
= res_ikind_2
;
3145 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3150 /* Generate code to allocate a string temporary. */
3153 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3158 if (gfc_can_put_var_on_stack (len
))
3160 /* Create a temporary variable to hold the result. */
3161 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3162 TREE_TYPE (len
), len
,
3163 build_int_cst (TREE_TYPE (len
), 1));
3164 tmp
= build_range_type (gfc_charlen_type_node
, size_zero_node
, tmp
);
3166 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3167 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3169 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3171 var
= gfc_create_var (tmp
, "str");
3172 var
= gfc_build_addr_expr (type
, var
);
3176 /* Allocate a temporary to hold the result. */
3177 var
= gfc_create_var (type
, "pstr");
3178 gcc_assert (POINTER_TYPE_P (type
));
3179 tmp
= TREE_TYPE (type
);
3180 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3181 tmp
= TREE_TYPE (tmp
);
3182 tmp
= TYPE_SIZE_UNIT (tmp
);
3183 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3184 fold_convert (size_type_node
, len
),
3185 fold_convert (size_type_node
, tmp
));
3186 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3187 gfc_add_modify (&se
->pre
, var
, tmp
);
3189 /* Free the temporary afterwards. */
3190 tmp
= gfc_call_free (var
);
3191 gfc_add_expr_to_block (&se
->post
, tmp
);
3198 /* Handle a string concatenation operation. A temporary will be allocated to
3202 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3205 tree len
, type
, var
, tmp
, fndecl
;
3207 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3208 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3209 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3211 gfc_init_se (&lse
, se
);
3212 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3213 gfc_conv_string_parameter (&lse
);
3214 gfc_init_se (&rse
, se
);
3215 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3216 gfc_conv_string_parameter (&rse
);
3218 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3219 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3221 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3222 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3223 if (len
== NULL_TREE
)
3225 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3226 gfc_charlen_type_node
,
3227 fold_convert (gfc_charlen_type_node
,
3229 fold_convert (gfc_charlen_type_node
,
3230 rse
.string_length
));
3233 type
= build_pointer_type (type
);
3235 var
= gfc_conv_string_tmp (se
, type
, len
);
3237 /* Do the actual concatenation. */
3238 if (expr
->ts
.kind
== 1)
3239 fndecl
= gfor_fndecl_concat_string
;
3240 else if (expr
->ts
.kind
== 4)
3241 fndecl
= gfor_fndecl_concat_string_char4
;
3245 tmp
= build_call_expr_loc (input_location
,
3246 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3247 rse
.string_length
, rse
.expr
);
3248 gfc_add_expr_to_block (&se
->pre
, tmp
);
3250 /* Add the cleanup for the operands. */
3251 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3252 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3255 se
->string_length
= len
;
3258 /* Translates an op expression. Common (binary) cases are handled by this
3259 function, others are passed on. Recursion is used in either case.
3260 We use the fact that (op1.ts == op2.ts) (except for the power
3262 Operators need no special handling for scalarized expressions as long as
3263 they call gfc_conv_simple_val to get their operands.
3264 Character strings get special handling. */
3267 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3269 enum tree_code code
;
3278 switch (expr
->value
.op
.op
)
3280 case INTRINSIC_PARENTHESES
:
3281 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3282 && flag_protect_parens
)
3284 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3285 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3290 case INTRINSIC_UPLUS
:
3291 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3294 case INTRINSIC_UMINUS
:
3295 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3299 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3302 case INTRINSIC_PLUS
:
3306 case INTRINSIC_MINUS
:
3310 case INTRINSIC_TIMES
:
3314 case INTRINSIC_DIVIDE
:
3315 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3316 an integer, we must round towards zero, so we use a
3318 if (expr
->ts
.type
== BT_INTEGER
)
3319 code
= TRUNC_DIV_EXPR
;
3324 case INTRINSIC_POWER
:
3325 gfc_conv_power_op (se
, expr
);
3328 case INTRINSIC_CONCAT
:
3329 gfc_conv_concat_op (se
, expr
);
3333 code
= TRUTH_ANDIF_EXPR
;
3338 code
= TRUTH_ORIF_EXPR
;
3342 /* EQV and NEQV only work on logicals, but since we represent them
3343 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3345 case INTRINSIC_EQ_OS
:
3353 case INTRINSIC_NE_OS
:
3354 case INTRINSIC_NEQV
:
3361 case INTRINSIC_GT_OS
:
3368 case INTRINSIC_GE_OS
:
3375 case INTRINSIC_LT_OS
:
3382 case INTRINSIC_LE_OS
:
3388 case INTRINSIC_USER
:
3389 case INTRINSIC_ASSIGN
:
3390 /* These should be converted into function calls by the frontend. */
3394 fatal_error (input_location
, "Unknown intrinsic op");
3398 /* The only exception to this is **, which is handled separately anyway. */
3399 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3401 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3405 gfc_init_se (&lse
, se
);
3406 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3407 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3410 gfc_init_se (&rse
, se
);
3411 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3412 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3416 gfc_conv_string_parameter (&lse
);
3417 gfc_conv_string_parameter (&rse
);
3419 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3420 rse
.string_length
, rse
.expr
,
3421 expr
->value
.op
.op1
->ts
.kind
,
3423 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3424 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3427 type
= gfc_typenode_for_spec (&expr
->ts
);
3431 /* The result of logical ops is always logical_type_node. */
3432 tmp
= fold_build2_loc (input_location
, code
, logical_type_node
,
3433 lse
.expr
, rse
.expr
);
3434 se
->expr
= convert (type
, tmp
);
3437 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3439 /* Add the post blocks. */
3440 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3441 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3444 /* If a string's length is one, we convert it to a single character. */
3447 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3451 || !tree_fits_uhwi_p (len
)
3452 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3455 if (TREE_INT_CST_LOW (len
) == 1)
3457 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3458 return build_fold_indirect_ref_loc (input_location
, str
);
3462 && TREE_CODE (str
) == ADDR_EXPR
3463 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3464 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3465 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3466 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3467 && TREE_INT_CST_LOW (len
) > 1
3468 && TREE_INT_CST_LOW (len
)
3469 == (unsigned HOST_WIDE_INT
)
3470 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3472 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3473 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3474 if (TREE_CODE (ret
) == INTEGER_CST
)
3476 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3477 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3478 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3480 for (i
= 1; i
< length
; i
++)
3493 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3496 if (sym
->backend_decl
)
3498 /* This becomes the nominal_type in
3499 function.c:assign_parm_find_data_types. */
3500 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3501 /* This becomes the passed_type in
3502 function.c:assign_parm_find_data_types. C promotes char to
3503 integer for argument passing. */
3504 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3506 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3511 /* If we have a constant character expression, make it into an
3513 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3518 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3519 (int)(*expr
)->value
.character
.string
[0]);
3520 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3522 /* The expr needs to be compatible with a C int. If the
3523 conversion fails, then the 2 causes an ICE. */
3524 ts
.type
= BT_INTEGER
;
3525 ts
.kind
= gfc_c_int_kind
;
3526 gfc_convert_type (*expr
, &ts
, 2);
3529 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3531 if ((*expr
)->ref
== NULL
)
3533 se
->expr
= gfc_string_to_single_character
3534 (build_int_cst (integer_type_node
, 1),
3535 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3537 ((*expr
)->symtree
->n
.sym
)),
3542 gfc_conv_variable (se
, *expr
);
3543 se
->expr
= gfc_string_to_single_character
3544 (build_int_cst (integer_type_node
, 1),
3545 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3553 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3554 if STR is a string literal, otherwise return -1. */
3557 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3560 && TREE_CODE (str
) == ADDR_EXPR
3561 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3562 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3563 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3564 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3565 && tree_fits_uhwi_p (len
)
3566 && tree_to_uhwi (len
) >= 1
3567 && tree_to_uhwi (len
)
3568 == (unsigned HOST_WIDE_INT
)
3569 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3571 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3572 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3573 if (TREE_CODE (folded
) == INTEGER_CST
)
3575 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3576 int length
= TREE_STRING_LENGTH (string_cst
);
3577 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3579 for (; length
> 0; length
--)
3580 if (ptr
[length
- 1] != ' ')
3589 /* Helper to build a call to memcmp. */
3592 build_memcmp_call (tree s1
, tree s2
, tree n
)
3596 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3597 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3599 s1
= fold_convert (pvoid_type_node
, s1
);
3601 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3602 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3604 s2
= fold_convert (pvoid_type_node
, s2
);
3606 n
= fold_convert (size_type_node
, n
);
3608 tmp
= build_call_expr_loc (input_location
,
3609 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3612 return fold_convert (integer_type_node
, tmp
);
3615 /* Compare two strings. If they are all single characters, the result is the
3616 subtraction of them. Otherwise, we build a library call. */
3619 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3620 enum tree_code code
)
3626 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3627 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3629 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3630 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3632 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3634 /* Deal with single character specially. */
3635 sc1
= fold_convert (integer_type_node
, sc1
);
3636 sc2
= fold_convert (integer_type_node
, sc2
);
3637 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3641 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3643 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3645 /* If one string is a string literal with LEN_TRIM longer
3646 than the length of the second string, the strings
3648 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3649 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3650 return integer_one_node
;
3651 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3652 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3653 return integer_one_node
;
3656 /* We can compare via memcpy if the strings are known to be equal
3657 in length and they are
3659 - kind=4 and the comparison is for (in)equality. */
3661 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3662 && tree_int_cst_equal (len1
, len2
)
3663 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3668 chartype
= gfc_get_char_type (kind
);
3669 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3670 fold_convert (TREE_TYPE(len1
),
3671 TYPE_SIZE_UNIT(chartype
)),
3673 return build_memcmp_call (str1
, str2
, tmp
);
3676 /* Build a call for the comparison. */
3678 fndecl
= gfor_fndecl_compare_string
;
3680 fndecl
= gfor_fndecl_compare_string_char4
;
3684 return build_call_expr_loc (input_location
, fndecl
, 4,
3685 len1
, str1
, len2
, str2
);
3689 /* Return the backend_decl for a procedure pointer component. */
3692 get_proc_ptr_comp (gfc_expr
*e
)
3698 gfc_init_se (&comp_se
, NULL
);
3699 e2
= gfc_copy_expr (e
);
3700 /* We have to restore the expr type later so that gfc_free_expr frees
3701 the exact same thing that was allocated.
3702 TODO: This is ugly. */
3703 old_type
= e2
->expr_type
;
3704 e2
->expr_type
= EXPR_VARIABLE
;
3705 gfc_conv_expr (&comp_se
, e2
);
3706 e2
->expr_type
= old_type
;
3708 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3712 /* Convert a typebound function reference from a class object. */
3714 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3719 if (!VAR_P (base_object
))
3721 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3722 gfc_add_modify (&se
->pre
, var
, base_object
);
3724 se
->expr
= gfc_class_vptr_get (base_object
);
3725 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3727 while (ref
&& ref
->next
)
3729 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3730 if (ref
->u
.c
.sym
->attr
.extension
)
3731 conv_parent_component_references (se
, ref
);
3732 gfc_conv_component_ref (se
, ref
);
3733 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3738 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3742 if (gfc_is_proc_ptr_comp (expr
))
3743 tmp
= get_proc_ptr_comp (expr
);
3744 else if (sym
->attr
.dummy
)
3746 tmp
= gfc_get_symbol_decl (sym
);
3747 if (sym
->attr
.proc_pointer
)
3748 tmp
= build_fold_indirect_ref_loc (input_location
,
3750 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3751 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3755 if (!sym
->backend_decl
)
3756 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3758 TREE_USED (sym
->backend_decl
) = 1;
3760 tmp
= sym
->backend_decl
;
3762 if (sym
->attr
.cray_pointee
)
3764 /* TODO - make the cray pointee a pointer to a procedure,
3765 assign the pointer to it and use it for the call. This
3767 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3768 gfc_get_symbol_decl (sym
->cp_pointer
));
3769 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3772 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3774 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3775 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3782 /* Initialize MAPPING. */
3785 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3787 mapping
->syms
= NULL
;
3788 mapping
->charlens
= NULL
;
3792 /* Free all memory held by MAPPING (but not MAPPING itself). */
3795 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3797 gfc_interface_sym_mapping
*sym
;
3798 gfc_interface_sym_mapping
*nextsym
;
3800 gfc_charlen
*nextcl
;
3802 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3804 nextsym
= sym
->next
;
3805 sym
->new_sym
->n
.sym
->formal
= NULL
;
3806 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3807 gfc_free_expr (sym
->expr
);
3808 free (sym
->new_sym
);
3811 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3814 gfc_free_expr (cl
->length
);
3820 /* Return a copy of gfc_charlen CL. Add the returned structure to
3821 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3823 static gfc_charlen
*
3824 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3827 gfc_charlen
*new_charlen
;
3829 new_charlen
= gfc_get_charlen ();
3830 new_charlen
->next
= mapping
->charlens
;
3831 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3833 mapping
->charlens
= new_charlen
;
3838 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3839 array variable that can be used as the actual argument for dummy
3840 argument SYM. Add any initialization code to BLOCK. PACKED is as
3841 for gfc_get_nodesc_array_type and DATA points to the first element
3842 in the passed array. */
3845 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3846 gfc_packed packed
, tree data
)
3851 type
= gfc_typenode_for_spec (&sym
->ts
);
3852 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3853 !sym
->attr
.target
&& !sym
->attr
.pointer
3854 && !sym
->attr
.proc_pointer
);
3856 var
= gfc_create_var (type
, "ifm");
3857 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3863 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3864 and offset of descriptorless array type TYPE given that it has the same
3865 size as DESC. Add any set-up code to BLOCK. */
3868 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3875 offset
= gfc_index_zero_node
;
3876 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3878 dim
= gfc_rank_cst
[n
];
3879 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3880 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3882 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3883 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3884 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3885 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3887 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3889 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3890 gfc_array_index_type
,
3891 gfc_conv_descriptor_ubound_get (desc
, dim
),
3892 gfc_conv_descriptor_lbound_get (desc
, dim
));
3893 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3894 gfc_array_index_type
,
3895 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3896 tmp
= gfc_evaluate_now (tmp
, block
);
3897 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3899 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3900 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3901 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3902 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3903 gfc_array_index_type
, offset
, tmp
);
3905 offset
= gfc_evaluate_now (offset
, block
);
3906 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3910 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3911 in SE. The caller may still use se->expr and se->string_length after
3912 calling this function. */
3915 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3916 gfc_symbol
* sym
, gfc_se
* se
,
3919 gfc_interface_sym_mapping
*sm
;
3923 gfc_symbol
*new_sym
;
3925 gfc_symtree
*new_symtree
;
3927 /* Create a new symbol to represent the actual argument. */
3928 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3929 new_sym
->ts
= sym
->ts
;
3930 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3931 new_sym
->attr
.referenced
= 1;
3932 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3933 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3934 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3935 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3936 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3937 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3938 new_sym
->attr
.function
= sym
->attr
.function
;
3940 /* Ensure that the interface is available and that
3941 descriptors are passed for array actual arguments. */
3942 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3944 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3945 new_sym
->attr
.always_explicit
3946 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3949 /* Create a fake symtree for it. */
3951 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3952 new_symtree
->n
.sym
= new_sym
;
3953 gcc_assert (new_symtree
== root
);
3955 /* Create a dummy->actual mapping. */
3956 sm
= XCNEW (gfc_interface_sym_mapping
);
3957 sm
->next
= mapping
->syms
;
3959 sm
->new_sym
= new_symtree
;
3960 sm
->expr
= gfc_copy_expr (expr
);
3963 /* Stabilize the argument's value. */
3964 if (!sym
->attr
.function
&& se
)
3965 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3967 if (sym
->ts
.type
== BT_CHARACTER
)
3969 /* Create a copy of the dummy argument's length. */
3970 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3971 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3973 /* If the length is specified as "*", record the length that
3974 the caller is passing. We should use the callee's length
3975 in all other cases. */
3976 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3978 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3979 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3986 /* Use the passed value as-is if the argument is a function. */
3987 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3990 /* If the argument is a pass-by-value scalar, use the value as is. */
3991 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3994 /* If the argument is either a string or a pointer to a string,
3995 convert it to a boundless character type. */
3996 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3998 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3999 tmp
= build_pointer_type (tmp
);
4000 if (sym
->attr
.pointer
)
4001 value
= build_fold_indirect_ref_loc (input_location
,
4005 value
= fold_convert (tmp
, value
);
4008 /* If the argument is a scalar, a pointer to an array or an allocatable,
4010 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
4011 value
= build_fold_indirect_ref_loc (input_location
,
4014 /* For character(*), use the actual argument's descriptor. */
4015 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
4016 value
= build_fold_indirect_ref_loc (input_location
,
4019 /* If the argument is an array descriptor, use it to determine
4020 information about the actual argument's shape. */
4021 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
4022 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
4024 /* Get the actual argument's descriptor. */
4025 desc
= build_fold_indirect_ref_loc (input_location
,
4028 /* Create the replacement variable. */
4029 tmp
= gfc_conv_descriptor_data_get (desc
);
4030 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4033 /* Use DESC to work out the upper bounds, strides and offset. */
4034 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
4037 /* Otherwise we have a packed array. */
4038 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
4039 PACKED_FULL
, se
->expr
);
4041 new_sym
->backend_decl
= value
;
4045 /* Called once all dummy argument mappings have been added to MAPPING,
4046 but before the mapping is used to evaluate expressions. Pre-evaluate
4047 the length of each argument, adding any initialization code to PRE and
4048 any finalization code to POST. */
4051 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
4052 stmtblock_t
* pre
, stmtblock_t
* post
)
4054 gfc_interface_sym_mapping
*sym
;
4058 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4059 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4060 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4062 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4063 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4064 gfc_init_se (&se
, NULL
);
4065 gfc_conv_expr (&se
, expr
);
4066 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4067 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4068 gfc_add_block_to_block (pre
, &se
.pre
);
4069 gfc_add_block_to_block (post
, &se
.post
);
4071 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4076 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4080 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4081 gfc_constructor_base base
)
4084 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4086 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4089 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4090 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4091 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4097 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4101 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4106 for (; ref
; ref
= ref
->next
)
4110 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4112 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4113 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4114 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4122 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4123 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4129 /* Convert intrinsic function calls into result expressions. */
4132 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4140 arg1
= expr
->value
.function
.actual
->expr
;
4141 if (expr
->value
.function
.actual
->next
)
4142 arg2
= expr
->value
.function
.actual
->next
->expr
;
4146 sym
= arg1
->symtree
->n
.sym
;
4148 if (sym
->attr
.dummy
)
4153 switch (expr
->value
.function
.isym
->id
)
4156 /* TODO figure out why this condition is necessary. */
4157 if (sym
->attr
.function
4158 && (arg1
->ts
.u
.cl
->length
== NULL
4159 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4160 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4163 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4166 case GFC_ISYM_LEN_TRIM
:
4167 new_expr
= gfc_copy_expr (arg1
);
4168 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4173 gfc_replace_expr (arg1
, new_expr
);
4177 if (!sym
->as
|| sym
->as
->rank
== 0)
4180 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4182 dup
= mpz_get_si (arg2
->value
.integer
);
4187 dup
= sym
->as
->rank
;
4191 for (; d
< dup
; d
++)
4195 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4197 gfc_free_expr (new_expr
);
4201 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4202 gfc_get_int_expr (gfc_default_integer_kind
,
4204 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4206 new_expr
= gfc_multiply (new_expr
, tmp
);
4212 case GFC_ISYM_LBOUND
:
4213 case GFC_ISYM_UBOUND
:
4214 /* TODO These implementations of lbound and ubound do not limit if
4215 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4217 if (!sym
->as
|| sym
->as
->rank
== 0)
4220 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4221 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4225 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4227 if (sym
->as
->lower
[d
])
4228 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4232 if (sym
->as
->upper
[d
])
4233 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4241 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4245 gfc_replace_expr (expr
, new_expr
);
4251 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4252 gfc_interface_mapping
* mapping
)
4254 gfc_formal_arglist
*f
;
4255 gfc_actual_arglist
*actual
;
4257 actual
= expr
->value
.function
.actual
;
4258 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4260 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4265 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4268 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4273 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4275 for (d
= 0; d
< as
->rank
; d
++)
4277 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4278 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4281 expr
->value
.function
.esym
->as
= as
;
4284 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4286 expr
->value
.function
.esym
->ts
.u
.cl
->length
4287 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4289 gfc_apply_interface_mapping_to_expr (mapping
,
4290 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4295 /* EXPR is a copy of an expression that appeared in the interface
4296 associated with MAPPING. Walk it recursively looking for references to
4297 dummy arguments that MAPPING maps to actual arguments. Replace each such
4298 reference with a reference to the associated actual argument. */
4301 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4304 gfc_interface_sym_mapping
*sym
;
4305 gfc_actual_arglist
*actual
;
4310 /* Copying an expression does not copy its length, so do that here. */
4311 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4313 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4314 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4317 /* Apply the mapping to any references. */
4318 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4320 /* ...and to the expression's symbol, if it has one. */
4321 /* TODO Find out why the condition on expr->symtree had to be moved into
4322 the loop rather than being outside it, as originally. */
4323 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4324 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4326 if (sym
->new_sym
->n
.sym
->backend_decl
)
4327 expr
->symtree
= sym
->new_sym
;
4329 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4332 /* ...and to subexpressions in expr->value. */
4333 switch (expr
->expr_type
)
4338 case EXPR_SUBSTRING
:
4342 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4343 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4347 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4348 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4350 if (expr
->value
.function
.esym
== NULL
4351 && expr
->value
.function
.isym
!= NULL
4352 && expr
->value
.function
.actual
->expr
->symtree
4353 && gfc_map_intrinsic_function (expr
, mapping
))
4356 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4357 if (sym
->old
== expr
->value
.function
.esym
)
4359 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4360 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4361 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4366 case EXPR_STRUCTURE
:
4367 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4380 /* Evaluate interface expression EXPR using MAPPING. Store the result
4384 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4385 gfc_se
* se
, gfc_expr
* expr
)
4387 expr
= gfc_copy_expr (expr
);
4388 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4389 gfc_conv_expr (se
, expr
);
4390 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4391 gfc_free_expr (expr
);
4395 /* Returns a reference to a temporary array into which a component of
4396 an actual argument derived type array is copied and then returned
4397 after the function call. */
4399 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4400 sym_intent intent
, bool formal_ptr
)
4408 gfc_array_info
*info
;
4418 gfc_init_se (&lse
, NULL
);
4419 gfc_init_se (&rse
, NULL
);
4421 /* Walk the argument expression. */
4422 rss
= gfc_walk_expr (expr
);
4424 gcc_assert (rss
!= gfc_ss_terminator
);
4426 /* Initialize the scalarizer. */
4427 gfc_init_loopinfo (&loop
);
4428 gfc_add_ss_to_loop (&loop
, rss
);
4430 /* Calculate the bounds of the scalarization. */
4431 gfc_conv_ss_startstride (&loop
);
4433 /* Build an ss for the temporary. */
4434 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4435 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4437 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4438 if (GFC_ARRAY_TYPE_P (base_type
)
4439 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4440 base_type
= gfc_get_element_type (base_type
);
4442 if (expr
->ts
.type
== BT_CLASS
)
4443 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4445 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4446 ? expr
->ts
.u
.cl
->backend_decl
4450 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4452 /* Associate the SS with the loop. */
4453 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4455 /* Setup the scalarizing loops. */
4456 gfc_conv_loop_setup (&loop
, &expr
->where
);
4458 /* Pass the temporary descriptor back to the caller. */
4459 info
= &loop
.temp_ss
->info
->data
.array
;
4460 parmse
->expr
= info
->descriptor
;
4462 /* Setup the gfc_se structures. */
4463 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4464 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4467 lse
.ss
= loop
.temp_ss
;
4468 gfc_mark_ss_chain_used (rss
, 1);
4469 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4471 /* Start the scalarized loop body. */
4472 gfc_start_scalarized_body (&loop
, &body
);
4474 /* Translate the expression. */
4475 gfc_conv_expr (&rse
, expr
);
4477 /* Reset the offset for the function call since the loop
4478 is zero based on the data pointer. Note that the temp
4479 comes first in the loop chain since it is added second. */
4480 if (gfc_is_class_array_function (expr
))
4482 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4483 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4484 gfc_index_zero_node
);
4487 gfc_conv_tmp_array_ref (&lse
);
4489 if (intent
!= INTENT_OUT
)
4491 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4492 gfc_add_expr_to_block (&body
, tmp
);
4493 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4494 gfc_trans_scalarizing_loops (&loop
, &body
);
4498 /* Make sure that the temporary declaration survives by merging
4499 all the loop declarations into the current context. */
4500 for (n
= 0; n
< loop
.dimen
; n
++)
4502 gfc_merge_block_scope (&body
);
4503 body
= loop
.code
[loop
.order
[n
]];
4505 gfc_merge_block_scope (&body
);
4508 /* Add the post block after the second loop, so that any
4509 freeing of allocated memory is done at the right time. */
4510 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4512 /**********Copy the temporary back again.*********/
4514 gfc_init_se (&lse
, NULL
);
4515 gfc_init_se (&rse
, NULL
);
4517 /* Walk the argument expression. */
4518 lss
= gfc_walk_expr (expr
);
4519 rse
.ss
= loop
.temp_ss
;
4522 /* Initialize the scalarizer. */
4523 gfc_init_loopinfo (&loop2
);
4524 gfc_add_ss_to_loop (&loop2
, lss
);
4526 dimen
= rse
.ss
->dimen
;
4528 /* Skip the write-out loop for this case. */
4529 if (gfc_is_class_array_function (expr
))
4530 goto class_array_fcn
;
4532 /* Calculate the bounds of the scalarization. */
4533 gfc_conv_ss_startstride (&loop2
);
4535 /* Setup the scalarizing loops. */
4536 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4538 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4539 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4541 gfc_mark_ss_chain_used (lss
, 1);
4542 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4544 /* Declare the variable to hold the temporary offset and start the
4545 scalarized loop body. */
4546 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4547 gfc_start_scalarized_body (&loop2
, &body
);
4549 /* Build the offsets for the temporary from the loop variables. The
4550 temporary array has lbounds of zero and strides of one in all
4551 dimensions, so this is very simple. The offset is only computed
4552 outside the innermost loop, so the overall transfer could be
4553 optimized further. */
4554 info
= &rse
.ss
->info
->data
.array
;
4556 tmp_index
= gfc_index_zero_node
;
4557 for (n
= dimen
- 1; n
> 0; n
--)
4560 tmp
= rse
.loop
->loopvar
[n
];
4561 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4562 tmp
, rse
.loop
->from
[n
]);
4563 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4566 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4567 gfc_array_index_type
,
4568 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4569 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4570 gfc_array_index_type
,
4571 tmp_str
, gfc_index_one_node
);
4573 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4574 gfc_array_index_type
, tmp
, tmp_str
);
4577 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4578 gfc_array_index_type
,
4579 tmp_index
, rse
.loop
->from
[0]);
4580 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4582 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4583 gfc_array_index_type
,
4584 rse
.loop
->loopvar
[0], offset
);
4586 /* Now use the offset for the reference. */
4587 tmp
= build_fold_indirect_ref_loc (input_location
,
4589 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4591 if (expr
->ts
.type
== BT_CHARACTER
)
4592 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4594 gfc_conv_expr (&lse
, expr
);
4596 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4598 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4599 gfc_add_expr_to_block (&body
, tmp
);
4601 /* Generate the copying loops. */
4602 gfc_trans_scalarizing_loops (&loop2
, &body
);
4604 /* Wrap the whole thing up by adding the second loop to the post-block
4605 and following it by the post-block of the first loop. In this way,
4606 if the temporary needs freeing, it is done after use! */
4607 if (intent
!= INTENT_IN
)
4609 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4610 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4615 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4617 gfc_cleanup_loop (&loop
);
4618 gfc_cleanup_loop (&loop2
);
4620 /* Pass the string length to the argument expression. */
4621 if (expr
->ts
.type
== BT_CHARACTER
)
4622 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4624 /* Determine the offset for pointer formal arguments and set the
4628 size
= gfc_index_one_node
;
4629 offset
= gfc_index_zero_node
;
4630 for (n
= 0; n
< dimen
; n
++)
4632 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4634 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4635 gfc_array_index_type
, tmp
,
4636 gfc_index_one_node
);
4637 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4641 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4644 gfc_index_one_node
);
4645 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4646 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4647 gfc_array_index_type
,
4649 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4650 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4651 gfc_array_index_type
,
4652 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4653 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4654 gfc_array_index_type
,
4655 tmp
, gfc_index_one_node
);
4656 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4657 gfc_array_index_type
, size
, tmp
);
4660 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4664 /* We want either the address for the data or the address of the descriptor,
4665 depending on the mode of passing array arguments. */
4667 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4669 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4675 /* Generate the code for argument list functions. */
4678 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4680 /* Pass by value for g77 %VAL(arg), pass the address
4681 indirectly for %LOC, else by reference. Thus %REF
4682 is a "do-nothing" and %LOC is the same as an F95
4684 if (strncmp (name
, "%VAL", 4) == 0)
4685 gfc_conv_expr (se
, expr
);
4686 else if (strncmp (name
, "%LOC", 4) == 0)
4688 gfc_conv_expr_reference (se
, expr
);
4689 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4691 else if (strncmp (name
, "%REF", 4) == 0)
4692 gfc_conv_expr_reference (se
, expr
);
4694 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4698 /* This function tells whether the middle-end representation of the expression
4699 E given as input may point to data otherwise accessible through a variable
4701 It is assumed that the only expressions that may alias are variables,
4702 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4704 This function is used to decide whether freeing an expression's allocatable
4705 components is safe or should be avoided.
4707 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4708 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4709 is necessary because for array constructors, aliasing depends on how
4711 - If E is an array constructor used as argument to an elemental procedure,
4712 the array, which is generated through shallow copy by the scalarizer,
4713 is used directly and can alias the expressions it was copied from.
4714 - If E is an array constructor used as argument to a non-elemental
4715 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4716 the array as in the previous case, but then that array is used
4717 to initialize a new descriptor through deep copy. There is no alias
4718 possible in that case.
4719 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4723 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4727 if (e
->expr_type
== EXPR_VARIABLE
)
4729 else if (e
->expr_type
== EXPR_FUNCTION
)
4731 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4733 if (proc_ifc
->result
!= NULL
4734 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4735 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4736 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4737 || proc_ifc
->result
->attr
.pointer
))
4742 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4745 for (c
= gfc_constructor_first (e
->value
.constructor
);
4746 c
; c
= gfc_constructor_next (c
))
4748 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4755 /* Generate code for a procedure call. Note can return se->post != NULL.
4756 If se->direct_byref is set then se->expr contains the return parameter.
4757 Return nonzero, if the call has alternate specifiers.
4758 'expr' is only needed for procedure pointer components. */
4761 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4762 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4763 vec
<tree
, va_gc
> *append_args
)
4765 gfc_interface_mapping mapping
;
4766 vec
<tree
, va_gc
> *arglist
;
4767 vec
<tree
, va_gc
> *retargs
;
4771 gfc_array_info
*info
;
4778 vec
<tree
, va_gc
> *stringargs
;
4779 vec
<tree
, va_gc
> *optionalargs
;
4781 gfc_formal_arglist
*formal
;
4782 gfc_actual_arglist
*arg
;
4783 int has_alternate_specifier
= 0;
4784 bool need_interface_mapping
;
4792 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4793 gfc_component
*comp
= NULL
;
4800 optionalargs
= NULL
;
4805 comp
= gfc_get_proc_ptr_comp (expr
);
4807 bool elemental_proc
= (comp
4808 && comp
->ts
.interface
4809 && comp
->ts
.interface
->attr
.elemental
)
4810 || (comp
&& comp
->attr
.elemental
)
4811 || sym
->attr
.elemental
;
4815 if (!elemental_proc
)
4817 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4818 if (se
->ss
->info
->useflags
)
4820 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4821 && sym
->result
->attr
.dimension
)
4822 || (comp
&& comp
->attr
.dimension
)
4823 || gfc_is_class_array_function (expr
));
4824 gcc_assert (se
->loop
!= NULL
);
4825 /* Access the previously obtained result. */
4826 gfc_conv_tmp_array_ref (se
);
4830 info
= &se
->ss
->info
->data
.array
;
4835 gfc_init_block (&post
);
4836 gfc_init_interface_mapping (&mapping
);
4839 formal
= gfc_sym_get_dummy_args (sym
);
4840 need_interface_mapping
= sym
->attr
.dimension
||
4841 (sym
->ts
.type
== BT_CHARACTER
4842 && sym
->ts
.u
.cl
->length
4843 && sym
->ts
.u
.cl
->length
->expr_type
4848 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4849 need_interface_mapping
= comp
->attr
.dimension
||
4850 (comp
->ts
.type
== BT_CHARACTER
4851 && comp
->ts
.u
.cl
->length
4852 && comp
->ts
.u
.cl
->length
->expr_type
4856 base_object
= NULL_TREE
;
4857 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4858 is the third and fourth argument to such a function call a value
4859 denoting the number of elements to copy (i.e., most of the time the
4860 length of a deferred length string). */
4861 ulim_copy
= (formal
== NULL
)
4862 && UNLIMITED_POLY (sym
)
4863 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4865 /* Evaluate the arguments. */
4866 for (arg
= args
, argc
= 0; arg
!= NULL
;
4867 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4870 fsym
= formal
? formal
->sym
: NULL
;
4871 parm_kind
= MISSING
;
4873 /* If the procedure requires an explicit interface, the actual
4874 argument is passed according to the corresponding formal
4875 argument. If the corresponding formal argument is a POINTER,
4876 ALLOCATABLE or assumed shape, we do not use g77's calling
4877 convention, and pass the address of the array descriptor
4878 instead. Otherwise we use g77's calling convention, in other words
4879 pass the array data pointer without descriptor. */
4880 bool nodesc_arg
= fsym
!= NULL
4881 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4883 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4884 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4886 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4888 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4890 /* Class array expressions are sometimes coming completely unadorned
4891 with either arrayspec or _data component. Correct that here.
4892 OOP-TODO: Move this to the frontend. */
4893 if (e
&& e
->expr_type
== EXPR_VARIABLE
4895 && e
->ts
.type
== BT_CLASS
4896 && (CLASS_DATA (e
)->attr
.codimension
4897 || CLASS_DATA (e
)->attr
.dimension
))
4899 gfc_typespec temp_ts
= e
->ts
;
4900 gfc_add_class_array_ref (e
);
4906 if (se
->ignore_optional
)
4908 /* Some intrinsics have already been resolved to the correct
4912 else if (arg
->label
)
4914 has_alternate_specifier
= 1;
4919 gfc_init_se (&parmse
, NULL
);
4921 /* For scalar arguments with VALUE attribute which are passed by
4922 value, pass "0" and a hidden argument gives the optional
4924 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4925 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4926 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4928 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4930 vec_safe_push (optionalargs
, boolean_false_node
);
4934 /* Pass a NULL pointer for an absent arg. */
4935 parmse
.expr
= null_pointer_node
;
4936 if (arg
->missing_arg_type
== BT_CHARACTER
)
4937 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4942 else if (arg
->expr
->expr_type
== EXPR_NULL
4943 && fsym
&& !fsym
->attr
.pointer
4944 && (fsym
->ts
.type
!= BT_CLASS
4945 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4947 /* Pass a NULL pointer to denote an absent arg. */
4948 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4949 && (fsym
->ts
.type
!= BT_CLASS
4950 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4951 gfc_init_se (&parmse
, NULL
);
4952 parmse
.expr
= null_pointer_node
;
4953 if (arg
->missing_arg_type
== BT_CHARACTER
)
4954 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4956 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4957 && e
->ts
.type
== BT_DERIVED
)
4959 /* The derived type needs to be converted to a temporary
4961 gfc_init_se (&parmse
, se
);
4962 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4964 && e
->expr_type
== EXPR_VARIABLE
4965 && e
->symtree
->n
.sym
->attr
.optional
,
4966 CLASS_DATA (fsym
)->attr
.class_pointer
4967 || CLASS_DATA (fsym
)->attr
.allocatable
);
4969 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4971 /* The intrinsic type needs to be converted to a temporary
4972 CLASS object for the unlimited polymorphic formal. */
4973 gfc_init_se (&parmse
, se
);
4974 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4976 else if (se
->ss
&& se
->ss
->info
->useflags
)
4982 /* An elemental function inside a scalarized loop. */
4983 gfc_init_se (&parmse
, se
);
4984 parm_kind
= ELEMENTAL
;
4986 /* When no fsym is present, ulim_copy is set and this is a third or
4987 fourth argument, use call-by-value instead of by reference to
4988 hand the length properties to the copy routine (i.e., most of the
4989 time this will be a call to a __copy_character_* routine where the
4990 third and fourth arguments are the lengths of a deferred length
4992 if ((fsym
&& fsym
->attr
.value
)
4993 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4994 gfc_conv_expr (&parmse
, e
);
4996 gfc_conv_expr_reference (&parmse
, e
);
4998 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4999 && e
->expr_type
== EXPR_FUNCTION
)
5000 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
5003 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
5004 && gfc_is_class_container_ref (e
))
5006 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5008 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
5009 && e
->symtree
->n
.sym
->attr
.optional
)
5011 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5012 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5013 TREE_TYPE (parmse
.expr
),
5015 fold_convert (TREE_TYPE (parmse
.expr
),
5016 null_pointer_node
));
5020 /* If we are passing an absent array as optional dummy to an
5021 elemental procedure, make sure that we pass NULL when the data
5022 pointer is NULL. We need this extra conditional because of
5023 scalarization which passes arrays elements to the procedure,
5024 ignoring the fact that the array can be absent/unallocated/... */
5025 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
5027 tree descriptor_data
;
5029 descriptor_data
= ss
->info
->data
.array
.data
;
5030 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
5032 fold_convert (TREE_TYPE (descriptor_data
),
5033 null_pointer_node
));
5035 = fold_build3_loc (input_location
, COND_EXPR
,
5036 TREE_TYPE (parmse
.expr
),
5037 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
5038 fold_convert (TREE_TYPE (parmse
.expr
),
5043 /* The scalarizer does not repackage the reference to a class
5044 array - instead it returns a pointer to the data element. */
5045 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
5046 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
5047 fsym
->attr
.intent
!= INTENT_IN
5048 && (CLASS_DATA (fsym
)->attr
.class_pointer
5049 || CLASS_DATA (fsym
)->attr
.allocatable
),
5051 && e
->expr_type
== EXPR_VARIABLE
5052 && e
->symtree
->n
.sym
->attr
.optional
,
5053 CLASS_DATA (fsym
)->attr
.class_pointer
5054 || CLASS_DATA (fsym
)->attr
.allocatable
);
5061 gfc_init_se (&parmse
, NULL
);
5063 /* Check whether the expression is a scalar or not; we cannot use
5064 e->rank as it can be nonzero for functions arguments. */
5065 argss
= gfc_walk_expr (e
);
5066 scalar
= argss
== gfc_ss_terminator
;
5068 gfc_free_ss_chain (argss
);
5070 /* Special handling for passing scalar polymorphic coarrays;
5071 otherwise one passes "class->_data.data" instead of "&class". */
5072 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5073 && fsym
&& fsym
->ts
.type
== BT_CLASS
5074 && CLASS_DATA (fsym
)->attr
.codimension
5075 && !CLASS_DATA (fsym
)->attr
.dimension
)
5077 gfc_add_class_array_ref (e
);
5078 parmse
.want_coarray
= 1;
5082 /* A scalar or transformational function. */
5085 if (e
->expr_type
== EXPR_VARIABLE
5086 && e
->symtree
->n
.sym
->attr
.cray_pointee
5087 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5089 /* The Cray pointer needs to be converted to a pointer to
5090 a type given by the expression. */
5091 gfc_conv_expr (&parmse
, e
);
5092 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5093 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5094 parmse
.expr
= convert (type
, tmp
);
5096 else if (fsym
&& fsym
->attr
.value
)
5098 if (fsym
->ts
.type
== BT_CHARACTER
5099 && fsym
->ts
.is_c_interop
5100 && fsym
->ns
->proc_name
!= NULL
5101 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5104 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5105 if (parmse
.expr
== NULL
)
5106 gfc_conv_expr (&parmse
, e
);
5110 gfc_conv_expr (&parmse
, e
);
5111 if (fsym
->attr
.optional
5112 && fsym
->ts
.type
!= BT_CLASS
5113 && fsym
->ts
.type
!= BT_DERIVED
)
5115 if (e
->expr_type
!= EXPR_VARIABLE
5116 || !e
->symtree
->n
.sym
->attr
.optional
5118 vec_safe_push (optionalargs
, boolean_true_node
);
5121 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5122 if (!e
->symtree
->n
.sym
->attr
.value
)
5124 = fold_build3_loc (input_location
, COND_EXPR
,
5125 TREE_TYPE (parmse
.expr
),
5127 fold_convert (TREE_TYPE (parmse
.expr
),
5128 integer_zero_node
));
5130 vec_safe_push (optionalargs
, tmp
);
5135 else if (arg
->name
&& arg
->name
[0] == '%')
5136 /* Argument list functions %VAL, %LOC and %REF are signalled
5137 through arg->name. */
5138 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5139 else if ((e
->expr_type
== EXPR_FUNCTION
)
5140 && ((e
->value
.function
.esym
5141 && e
->value
.function
.esym
->result
->attr
.pointer
)
5142 || (!e
->value
.function
.esym
5143 && e
->symtree
->n
.sym
->attr
.pointer
))
5144 && fsym
&& fsym
->attr
.target
)
5146 gfc_conv_expr (&parmse
, e
);
5147 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5149 else if (e
->expr_type
== EXPR_FUNCTION
5150 && e
->symtree
->n
.sym
->result
5151 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5152 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5154 /* Functions returning procedure pointers. */
5155 gfc_conv_expr (&parmse
, e
);
5156 if (fsym
&& fsym
->attr
.proc_pointer
)
5157 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5161 if (e
->ts
.type
== BT_CLASS
&& fsym
5162 && fsym
->ts
.type
== BT_CLASS
5163 && (!CLASS_DATA (fsym
)->as
5164 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5165 && CLASS_DATA (e
)->attr
.codimension
)
5167 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5168 gcc_assert (!CLASS_DATA (fsym
)->as
);
5169 gfc_add_class_array_ref (e
);
5170 parmse
.want_coarray
= 1;
5171 gfc_conv_expr_reference (&parmse
, e
);
5172 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5174 && e
->expr_type
== EXPR_VARIABLE
);
5176 else if (e
->ts
.type
== BT_CLASS
&& fsym
5177 && fsym
->ts
.type
== BT_CLASS
5178 && !CLASS_DATA (fsym
)->as
5179 && !CLASS_DATA (e
)->as
5180 && strcmp (fsym
->ts
.u
.derived
->name
,
5181 e
->ts
.u
.derived
->name
))
5183 type
= gfc_typenode_for_spec (&fsym
->ts
);
5184 var
= gfc_create_var (type
, fsym
->name
);
5185 gfc_conv_expr (&parmse
, e
);
5186 if (fsym
->attr
.optional
5187 && e
->expr_type
== EXPR_VARIABLE
5188 && e
->symtree
->n
.sym
->attr
.optional
)
5192 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5193 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5194 logical_type_node
, tmp
,
5195 fold_convert (TREE_TYPE (tmp
),
5196 null_pointer_node
));
5197 gfc_start_block (&block
);
5198 gfc_add_modify (&block
, var
,
5199 fold_build1_loc (input_location
,
5201 type
, parmse
.expr
));
5202 gfc_add_expr_to_block (&parmse
.pre
,
5203 fold_build3_loc (input_location
,
5204 COND_EXPR
, void_type_node
,
5205 cond
, gfc_finish_block (&block
),
5206 build_empty_stmt (input_location
)));
5207 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5208 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5209 TREE_TYPE (parmse
.expr
),
5211 fold_convert (TREE_TYPE (parmse
.expr
),
5212 null_pointer_node
));
5216 /* Since the internal representation of unlimited
5217 polymorphic expressions includes an extra field
5218 that other class objects do not, a cast to the
5219 formal type does not work. */
5220 if (!UNLIMITED_POLY (e
) && UNLIMITED_POLY (fsym
))
5224 /* Set the _data field. */
5225 tmp
= gfc_class_data_get (var
);
5226 efield
= fold_convert (TREE_TYPE (tmp
),
5227 gfc_class_data_get (parmse
.expr
));
5228 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5230 /* Set the _vptr field. */
5231 tmp
= gfc_class_vptr_get (var
);
5232 efield
= fold_convert (TREE_TYPE (tmp
),
5233 gfc_class_vptr_get (parmse
.expr
));
5234 gfc_add_modify (&parmse
.pre
, tmp
, efield
);
5236 /* Set the _len field. */
5237 tmp
= gfc_class_len_get (var
);
5238 gfc_add_modify (&parmse
.pre
, tmp
,
5239 build_int_cst (TREE_TYPE (tmp
), 0));
5243 tmp
= fold_build1_loc (input_location
,
5246 gfc_add_modify (&parmse
.pre
, var
, tmp
);
5249 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5253 gfc_conv_expr_reference (&parmse
, e
);
5255 /* Catch base objects that are not variables. */
5256 if (e
->ts
.type
== BT_CLASS
5257 && e
->expr_type
!= EXPR_VARIABLE
5258 && expr
&& e
== expr
->base_expr
)
5259 base_object
= build_fold_indirect_ref_loc (input_location
,
5262 /* A class array element needs converting back to be a
5263 class object, if the formal argument is a class object. */
5264 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5265 && e
->ts
.type
== BT_CLASS
5266 && ((CLASS_DATA (fsym
)->as
5267 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5268 || CLASS_DATA (e
)->attr
.dimension
))
5269 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5270 fsym
->attr
.intent
!= INTENT_IN
5271 && (CLASS_DATA (fsym
)->attr
.class_pointer
5272 || CLASS_DATA (fsym
)->attr
.allocatable
),
5274 && e
->expr_type
== EXPR_VARIABLE
5275 && e
->symtree
->n
.sym
->attr
.optional
,
5276 CLASS_DATA (fsym
)->attr
.class_pointer
5277 || CLASS_DATA (fsym
)->attr
.allocatable
);
5279 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5280 allocated on entry, it must be deallocated. */
5281 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5282 && (fsym
->attr
.allocatable
5283 || (fsym
->ts
.type
== BT_CLASS
5284 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5289 gfc_init_block (&block
);
5291 if (e
->ts
.type
== BT_CLASS
)
5292 ptr
= gfc_class_data_get (ptr
);
5294 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5297 gfc_add_expr_to_block (&block
, tmp
);
5298 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5299 void_type_node
, ptr
,
5301 gfc_add_expr_to_block (&block
, tmp
);
5303 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5305 gfc_add_modify (&block
, ptr
,
5306 fold_convert (TREE_TYPE (ptr
),
5307 null_pointer_node
));
5308 gfc_add_expr_to_block (&block
, tmp
);
5310 else if (fsym
->ts
.type
== BT_CLASS
)
5313 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5314 tmp
= gfc_get_symbol_decl (vtab
);
5315 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5316 ptr
= gfc_class_vptr_get (parmse
.expr
);
5317 gfc_add_modify (&block
, ptr
,
5318 fold_convert (TREE_TYPE (ptr
), tmp
));
5319 gfc_add_expr_to_block (&block
, tmp
);
5322 if (fsym
->attr
.optional
5323 && e
->expr_type
== EXPR_VARIABLE
5324 && e
->symtree
->n
.sym
->attr
.optional
)
5326 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5328 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5329 gfc_finish_block (&block
),
5330 build_empty_stmt (input_location
));
5333 tmp
= gfc_finish_block (&block
);
5335 gfc_add_expr_to_block (&se
->pre
, tmp
);
5338 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5339 || fsym
->ts
.type
== BT_ASSUMED
)
5340 && e
->ts
.type
== BT_CLASS
5341 && !CLASS_DATA (e
)->attr
.dimension
5342 && !CLASS_DATA (e
)->attr
.codimension
)
5343 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5345 /* Wrap scalar variable in a descriptor. We need to convert
5346 the address of a pointer back to the pointer itself before,
5347 we can assign it to the data field. */
5349 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5350 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5353 if (TREE_CODE (tmp
) == ADDR_EXPR
)
5354 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5355 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5357 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5360 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5361 && ((fsym
->attr
.pointer
5362 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5363 || (fsym
->attr
.proc_pointer
5364 && !(e
->expr_type
== EXPR_VARIABLE
5365 && e
->symtree
->n
.sym
->attr
.dummy
))
5366 || (fsym
->attr
.proc_pointer
5367 && e
->expr_type
== EXPR_VARIABLE
5368 && gfc_is_proc_ptr_comp (e
))
5369 || (fsym
->attr
.allocatable
5370 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5372 /* Scalar pointer dummy args require an extra level of
5373 indirection. The null pointer already contains
5374 this level of indirection. */
5375 parm_kind
= SCALAR_POINTER
;
5376 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5380 else if (e
->ts
.type
== BT_CLASS
5381 && fsym
&& fsym
->ts
.type
== BT_CLASS
5382 && (CLASS_DATA (fsym
)->attr
.dimension
5383 || CLASS_DATA (fsym
)->attr
.codimension
))
5385 /* Pass a class array. */
5386 parmse
.use_offset
= 1;
5387 gfc_conv_expr_descriptor (&parmse
, e
);
5389 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5390 allocated on entry, it must be deallocated. */
5391 if (fsym
->attr
.intent
== INTENT_OUT
5392 && CLASS_DATA (fsym
)->attr
.allocatable
)
5397 gfc_init_block (&block
);
5399 ptr
= gfc_class_data_get (ptr
);
5401 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5402 NULL_TREE
, NULL_TREE
,
5404 GFC_CAF_COARRAY_NOCOARRAY
);
5405 gfc_add_expr_to_block (&block
, tmp
);
5406 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5407 void_type_node
, ptr
,
5409 gfc_add_expr_to_block (&block
, tmp
);
5410 gfc_reset_vptr (&block
, e
);
5412 if (fsym
->attr
.optional
5413 && e
->expr_type
== EXPR_VARIABLE
5415 || (e
->ref
->type
== REF_ARRAY
5416 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5417 && e
->symtree
->n
.sym
->attr
.optional
)
5419 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5421 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5422 gfc_finish_block (&block
),
5423 build_empty_stmt (input_location
));
5426 tmp
= gfc_finish_block (&block
);
5428 gfc_add_expr_to_block (&se
->pre
, tmp
);
5431 /* The conversion does not repackage the reference to a class
5432 array - _data descriptor. */
5433 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5434 fsym
->attr
.intent
!= INTENT_IN
5435 && (CLASS_DATA (fsym
)->attr
.class_pointer
5436 || CLASS_DATA (fsym
)->attr
.allocatable
),
5438 && e
->expr_type
== EXPR_VARIABLE
5439 && e
->symtree
->n
.sym
->attr
.optional
,
5440 CLASS_DATA (fsym
)->attr
.class_pointer
5441 || CLASS_DATA (fsym
)->attr
.allocatable
);
5445 /* If the argument is a function call that may not create
5446 a temporary for the result, we have to check that we
5447 can do it, i.e. that there is no alias between this
5448 argument and another one. */
5449 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5455 intent
= fsym
->attr
.intent
;
5457 intent
= INTENT_UNKNOWN
;
5459 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5461 parmse
.force_tmp
= 1;
5463 iarg
= e
->value
.function
.actual
->expr
;
5465 /* Temporary needed if aliasing due to host association. */
5466 if (sym
->attr
.contained
5468 && !sym
->attr
.implicit_pure
5469 && !sym
->attr
.use_assoc
5470 && iarg
->expr_type
== EXPR_VARIABLE
5471 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5472 parmse
.force_tmp
= 1;
5474 /* Ditto within module. */
5475 if (sym
->attr
.use_assoc
5477 && !sym
->attr
.implicit_pure
5478 && iarg
->expr_type
== EXPR_VARIABLE
5479 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5480 parmse
.force_tmp
= 1;
5483 if (e
->expr_type
== EXPR_VARIABLE
5484 && is_subref_array (e
)
5485 && !(fsym
&& fsym
->attr
.pointer
))
5486 /* The actual argument is a component reference to an
5487 array of derived types. In this case, the argument
5488 is converted to a temporary, which is passed and then
5489 written back after the procedure call. */
5490 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5491 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5492 fsym
&& fsym
->attr
.pointer
);
5493 else if (gfc_is_class_array_ref (e
, NULL
)
5494 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5495 /* The actual argument is a component reference to an
5496 array of derived types. In this case, the argument
5497 is converted to a temporary, which is passed and then
5498 written back after the procedure call.
5499 OOP-TODO: Insert code so that if the dynamic type is
5500 the same as the declared type, copy-in/copy-out does
5502 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5503 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5504 fsym
&& fsym
->attr
.pointer
);
5506 else if (gfc_is_class_array_function (e
)
5507 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5508 /* See previous comment. For function actual argument,
5509 the write out is not needed so the intent is set as
5512 e
->must_finalize
= 1;
5513 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5515 fsym
&& fsym
->attr
.pointer
);
5518 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5521 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5522 allocated on entry, it must be deallocated. */
5523 if (fsym
&& fsym
->attr
.allocatable
5524 && fsym
->attr
.intent
== INTENT_OUT
)
5526 if (fsym
->ts
.type
== BT_DERIVED
5527 && fsym
->ts
.u
.derived
->attr
.alloc_comp
)
5529 // deallocate the components first
5530 tmp
= gfc_deallocate_alloc_comp (fsym
->ts
.u
.derived
,
5531 parmse
.expr
, e
->rank
);
5532 if (tmp
!= NULL_TREE
)
5533 gfc_add_expr_to_block (&se
->pre
, tmp
);
5536 tmp
= build_fold_indirect_ref_loc (input_location
,
5538 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5539 tmp
= gfc_conv_descriptor_data_get (tmp
);
5540 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5541 NULL_TREE
, NULL_TREE
, true,
5543 GFC_CAF_COARRAY_NOCOARRAY
);
5544 if (fsym
->attr
.optional
5545 && e
->expr_type
== EXPR_VARIABLE
5546 && e
->symtree
->n
.sym
->attr
.optional
)
5547 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5549 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5550 tmp
, build_empty_stmt (input_location
));
5551 gfc_add_expr_to_block (&se
->pre
, tmp
);
5556 /* The case with fsym->attr.optional is that of a user subroutine
5557 with an interface indicating an optional argument. When we call
5558 an intrinsic subroutine, however, fsym is NULL, but we might still
5559 have an optional argument, so we proceed to the substitution
5561 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5563 /* If an optional argument is itself an optional dummy argument,
5564 check its presence and substitute a null if absent. This is
5565 only needed when passing an array to an elemental procedure
5566 as then array elements are accessed - or no NULL pointer is
5567 allowed and a "1" or "0" should be passed if not present.
5568 When passing a non-array-descriptor full array to a
5569 non-array-descriptor dummy, no check is needed. For
5570 array-descriptor actual to array-descriptor dummy, see
5571 PR 41911 for why a check has to be inserted.
5572 fsym == NULL is checked as intrinsics required the descriptor
5573 but do not always set fsym. */
5574 if (e
->expr_type
== EXPR_VARIABLE
5575 && e
->symtree
->n
.sym
->attr
.optional
5576 && ((e
->rank
!= 0 && elemental_proc
)
5577 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5581 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5582 || fsym
->as
->type
== AS_ASSUMED_RANK
5583 || fsym
->as
->type
== AS_DEFERRED
))))))
5584 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5585 e
->representation
.length
);
5590 /* Obtain the character length of an assumed character length
5591 length procedure from the typespec. */
5592 if (fsym
->ts
.type
== BT_CHARACTER
5593 && parmse
.string_length
== NULL_TREE
5594 && e
->ts
.type
== BT_PROCEDURE
5595 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5596 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5597 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5599 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5600 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5604 if (fsym
&& need_interface_mapping
&& e
)
5605 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5607 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5608 gfc_add_block_to_block (&post
, &parmse
.post
);
5610 /* Allocated allocatable components of derived types must be
5611 deallocated for non-variable scalars, array arguments to elemental
5612 procedures, and array arguments with descriptor to non-elemental
5613 procedures. As bounds information for descriptorless arrays is no
5614 longer available here, they are dealt with in trans-array.c
5615 (gfc_conv_array_parameter). */
5616 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5617 && e
->ts
.u
.derived
->attr
.alloc_comp
5618 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5619 && !expr_may_alias_variables (e
, elemental_proc
))
5622 /* It is known the e returns a structure type with at least one
5623 allocatable component. When e is a function, ensure that the
5624 function is called once only by using a temporary variable. */
5625 if (!DECL_P (parmse
.expr
))
5626 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5627 parmse
.expr
, &se
->pre
);
5629 if (fsym
&& fsym
->attr
.value
)
5632 tmp
= build_fold_indirect_ref_loc (input_location
,
5635 parm_rank
= e
->rank
;
5643 case (SCALAR_POINTER
):
5644 tmp
= build_fold_indirect_ref_loc (input_location
,
5649 if (e
->expr_type
== EXPR_OP
5650 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5651 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5654 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5655 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
,
5657 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5660 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5662 /* The derived type is passed to gfc_deallocate_alloc_comp.
5663 Therefore, class actuals can handled correctly but derived
5664 types passed to class formals need the _data component. */
5665 tmp
= gfc_class_data_get (tmp
);
5666 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5667 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5670 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5672 gfc_prepend_expr_to_block (&post
, tmp
);
5675 /* Add argument checking of passing an unallocated/NULL actual to
5676 a nonallocatable/nonpointer dummy. */
5678 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5680 symbol_attribute attr
;
5684 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5685 attr
= gfc_expr_attr (e
);
5687 goto end_pointer_check
;
5689 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5690 allocatable to an optional dummy, cf. 12.5.2.12. */
5691 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5692 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5693 goto end_pointer_check
;
5697 /* If the actual argument is an optional pointer/allocatable and
5698 the formal argument takes an nonpointer optional value,
5699 it is invalid to pass a non-present argument on, even
5700 though there is no technical reason for this in gfortran.
5701 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5702 tree present
, null_ptr
, type
;
5704 if (attr
.allocatable
5705 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5706 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5707 "allocated or not present",
5708 e
->symtree
->n
.sym
->name
);
5709 else if (attr
.pointer
5710 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5711 msg
= xasprintf ("Pointer actual argument '%s' is not "
5712 "associated or not present",
5713 e
->symtree
->n
.sym
->name
);
5714 else if (attr
.proc_pointer
5715 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5716 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5717 "associated or not present",
5718 e
->symtree
->n
.sym
->name
);
5720 goto end_pointer_check
;
5722 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5723 type
= TREE_TYPE (present
);
5724 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5725 logical_type_node
, present
,
5727 null_pointer_node
));
5728 type
= TREE_TYPE (parmse
.expr
);
5729 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5730 logical_type_node
, parmse
.expr
,
5732 null_pointer_node
));
5733 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5734 logical_type_node
, present
, null_ptr
);
5738 if (attr
.allocatable
5739 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5740 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5741 "allocated", e
->symtree
->n
.sym
->name
);
5742 else if (attr
.pointer
5743 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5744 msg
= xasprintf ("Pointer actual argument '%s' is not "
5745 "associated", e
->symtree
->n
.sym
->name
);
5746 else if (attr
.proc_pointer
5747 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5748 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5749 "associated", e
->symtree
->n
.sym
->name
);
5751 goto end_pointer_check
;
5755 /* If the argument is passed by value, we need to strip the
5757 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5758 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5760 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5761 logical_type_node
, tmp
,
5762 fold_convert (TREE_TYPE (tmp
),
5763 null_pointer_node
));
5766 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5772 /* Deferred length dummies pass the character length by reference
5773 so that the value can be returned. */
5774 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5776 if (INDIRECT_REF_P (parmse
.string_length
))
5777 /* In chains of functions/procedure calls the string_length already
5778 is a pointer to the variable holding the length. Therefore
5779 remove the deref on call. */
5780 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5783 tmp
= parmse
.string_length
;
5784 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5785 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5786 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5790 /* Character strings are passed as two parameters, a length and a
5791 pointer - except for Bind(c) which only passes the pointer.
5792 An unlimited polymorphic formal argument likewise does not
5794 if (parmse
.string_length
!= NULL_TREE
5795 && !sym
->attr
.is_bind_c
5796 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5797 vec_safe_push (stringargs
, parmse
.string_length
);
5799 /* When calling __copy for character expressions to unlimited
5800 polymorphic entities, the dst argument needs a string length. */
5801 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5802 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5803 && arg
->next
&& arg
->next
->expr
5804 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5805 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5806 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5807 vec_safe_push (stringargs
, parmse
.string_length
);
5809 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5810 pass the token and the offset as additional arguments. */
5811 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5812 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5813 && !fsym
->attr
.allocatable
)
5814 || (fsym
->ts
.type
== BT_CLASS
5815 && CLASS_DATA (fsym
)->attr
.codimension
5816 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5818 /* Token and offset. */
5819 vec_safe_push (stringargs
, null_pointer_node
);
5820 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5821 gcc_assert (fsym
->attr
.optional
);
5823 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5824 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5825 && !fsym
->attr
.allocatable
)
5826 || (fsym
->ts
.type
== BT_CLASS
5827 && CLASS_DATA (fsym
)->attr
.codimension
5828 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5830 tree caf_decl
, caf_type
;
5833 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5834 caf_type
= TREE_TYPE (caf_decl
);
5836 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5837 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5838 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5839 tmp
= gfc_conv_descriptor_token (caf_decl
);
5840 else if (DECL_LANG_SPECIFIC (caf_decl
)
5841 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5842 tmp
= GFC_DECL_TOKEN (caf_decl
);
5845 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5846 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5847 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5850 vec_safe_push (stringargs
, tmp
);
5852 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5853 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5854 offset
= build_int_cst (gfc_array_index_type
, 0);
5855 else if (DECL_LANG_SPECIFIC (caf_decl
)
5856 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5857 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5858 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5859 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5861 offset
= build_int_cst (gfc_array_index_type
, 0);
5863 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5864 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5867 gcc_assert (POINTER_TYPE_P (caf_type
));
5871 tmp2
= fsym
->ts
.type
== BT_CLASS
5872 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5873 if ((fsym
->ts
.type
!= BT_CLASS
5874 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5875 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5876 || (fsym
->ts
.type
== BT_CLASS
5877 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5878 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5880 if (fsym
->ts
.type
== BT_CLASS
)
5881 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5884 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5885 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5887 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5888 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5890 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5891 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5894 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5897 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5898 gfc_array_index_type
,
5899 fold_convert (gfc_array_index_type
, tmp2
),
5900 fold_convert (gfc_array_index_type
, tmp
));
5901 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5902 gfc_array_index_type
, offset
, tmp
);
5904 vec_safe_push (stringargs
, offset
);
5907 vec_safe_push (arglist
, parmse
.expr
);
5909 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5913 else if (sym
->ts
.type
== BT_CLASS
)
5914 ts
= CLASS_DATA (sym
)->ts
;
5918 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5919 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5920 else if (ts
.type
== BT_CHARACTER
)
5922 if (ts
.u
.cl
->length
== NULL
)
5924 /* Assumed character length results are not allowed by 5.1.1.5 of the
5925 standard and are trapped in resolve.c; except in the case of SPREAD
5926 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5927 we take the character length of the first argument for the result.
5928 For dummies, we have to look through the formal argument list for
5929 this function and use the character length found there.*/
5931 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5932 else if (!sym
->attr
.dummy
)
5933 cl
.backend_decl
= (*stringargs
)[0];
5936 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5937 for (; formal
; formal
= formal
->next
)
5938 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5939 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5941 len
= cl
.backend_decl
;
5947 /* Calculate the length of the returned string. */
5948 gfc_init_se (&parmse
, NULL
);
5949 if (need_interface_mapping
)
5950 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5952 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5953 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5954 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5956 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5957 TREE_TYPE (tmp
), tmp
,
5958 build_zero_cst (TREE_TYPE (tmp
)));
5959 cl
.backend_decl
= tmp
;
5962 /* Set up a charlen structure for it. */
5967 len
= cl
.backend_decl
;
5970 byref
= (comp
&& (comp
->attr
.dimension
5971 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5972 || (!comp
&& gfc_return_by_reference (sym
));
5975 if (se
->direct_byref
)
5977 /* Sometimes, too much indirection can be applied; e.g. for
5978 function_result = array_valued_recursive_function. */
5979 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5980 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5981 && GFC_DESCRIPTOR_TYPE_P
5982 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5983 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5986 /* If the lhs of an assignment x = f(..) is allocatable and
5987 f2003 is allowed, we must do the automatic reallocation.
5988 TODO - deal with intrinsics, without using a temporary. */
5989 if (flag_realloc_lhs
5990 && se
->ss
&& se
->ss
->loop_chain
5991 && se
->ss
->loop_chain
->is_alloc_lhs
5992 && !expr
->value
.function
.isym
5993 && sym
->result
->as
!= NULL
)
5995 /* Evaluate the bounds of the result, if known. */
5996 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5999 /* Perform the automatic reallocation. */
6000 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
6002 gfc_add_expr_to_block (&se
->pre
, tmp
);
6004 /* Pass the temporary as the first argument. */
6005 result
= info
->descriptor
;
6008 result
= build_fold_indirect_ref_loc (input_location
,
6010 vec_safe_push (retargs
, se
->expr
);
6012 else if (comp
&& comp
->attr
.dimension
)
6014 gcc_assert (se
->loop
&& info
);
6016 /* Set the type of the array. */
6017 tmp
= gfc_typenode_for_spec (&comp
->ts
);
6018 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6020 /* Evaluate the bounds of the result, if known. */
6021 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
6023 /* If the lhs of an assignment x = f(..) is allocatable and
6024 f2003 is allowed, we must not generate the function call
6025 here but should just send back the results of the mapping.
6026 This is signalled by the function ss being flagged. */
6027 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6029 gfc_free_interface_mapping (&mapping
);
6030 return has_alternate_specifier
;
6033 /* Create a temporary to store the result. In case the function
6034 returns a pointer, the temporary will be a shallow copy and
6035 mustn't be deallocated. */
6036 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
6037 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6038 tmp
, NULL_TREE
, false,
6039 !comp
->attr
.pointer
, callee_alloc
,
6040 &se
->ss
->info
->expr
->where
);
6042 /* Pass the temporary as the first argument. */
6043 result
= info
->descriptor
;
6044 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6045 vec_safe_push (retargs
, tmp
);
6047 else if (!comp
&& sym
->result
->attr
.dimension
)
6049 gcc_assert (se
->loop
&& info
);
6051 /* Set the type of the array. */
6052 tmp
= gfc_typenode_for_spec (&ts
);
6053 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
6055 /* Evaluate the bounds of the result, if known. */
6056 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
6058 /* If the lhs of an assignment x = f(..) is allocatable and
6059 f2003 is allowed, we must not generate the function call
6060 here but should just send back the results of the mapping.
6061 This is signalled by the function ss being flagged. */
6062 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
6064 gfc_free_interface_mapping (&mapping
);
6065 return has_alternate_specifier
;
6068 /* Create a temporary to store the result. In case the function
6069 returns a pointer, the temporary will be a shallow copy and
6070 mustn't be deallocated. */
6071 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
6072 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
6073 tmp
, NULL_TREE
, false,
6074 !sym
->attr
.pointer
, callee_alloc
,
6075 &se
->ss
->info
->expr
->where
);
6077 /* Pass the temporary as the first argument. */
6078 result
= info
->descriptor
;
6079 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
6080 vec_safe_push (retargs
, tmp
);
6082 else if (ts
.type
== BT_CHARACTER
)
6084 /* Pass the string length. */
6085 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
6086 type
= build_pointer_type (type
);
6088 /* Emit a DECL_EXPR for the VLA type. */
6089 tmp
= TREE_TYPE (type
);
6091 && TREE_CODE (TYPE_SIZE (tmp
)) != INTEGER_CST
)
6093 tmp
= build_decl (input_location
, TYPE_DECL
, NULL_TREE
, tmp
);
6094 DECL_ARTIFICIAL (tmp
) = 1;
6095 DECL_IGNORED_P (tmp
) = 1;
6096 tmp
= fold_build1_loc (input_location
, DECL_EXPR
,
6097 TREE_TYPE (tmp
), tmp
);
6098 gfc_add_expr_to_block (&se
->pre
, tmp
);
6101 /* Return an address to a char[0:len-1]* temporary for
6102 character pointers. */
6103 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6104 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6106 var
= gfc_create_var (type
, "pstr");
6108 if ((!comp
&& sym
->attr
.allocatable
)
6109 || (comp
&& comp
->attr
.allocatable
))
6111 gfc_add_modify (&se
->pre
, var
,
6112 fold_convert (TREE_TYPE (var
),
6113 null_pointer_node
));
6114 tmp
= gfc_call_free (var
);
6115 gfc_add_expr_to_block (&se
->post
, tmp
);
6118 /* Provide an address expression for the function arguments. */
6119 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6122 var
= gfc_conv_string_tmp (se
, type
, len
);
6124 vec_safe_push (retargs
, var
);
6128 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6130 type
= gfc_get_complex_type (ts
.kind
);
6131 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6132 vec_safe_push (retargs
, var
);
6135 /* Add the string length to the argument list. */
6136 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6140 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6141 TREE_STATIC (tmp
) = 1;
6142 gfc_add_modify (&se
->pre
, tmp
,
6143 build_int_cst (TREE_TYPE (tmp
), 0));
6144 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6145 vec_safe_push (retargs
, tmp
);
6147 else if (ts
.type
== BT_CHARACTER
)
6148 vec_safe_push (retargs
, len
);
6150 gfc_free_interface_mapping (&mapping
);
6152 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6153 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6154 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6155 vec_safe_reserve (retargs
, arglen
);
6157 /* Add the return arguments. */
6158 vec_safe_splice (retargs
, arglist
);
6160 /* Add the hidden present status for optional+value to the arguments. */
6161 vec_safe_splice (retargs
, optionalargs
);
6163 /* Add the hidden string length parameters to the arguments. */
6164 vec_safe_splice (retargs
, stringargs
);
6166 /* We may want to append extra arguments here. This is used e.g. for
6167 calls to libgfortran_matmul_??, which need extra information. */
6168 vec_safe_splice (retargs
, append_args
);
6172 /* Generate the actual call. */
6173 if (base_object
== NULL_TREE
)
6174 conv_function_val (se
, sym
, expr
);
6176 conv_base_obj_fcn_val (se
, base_object
, expr
);
6178 /* If there are alternate return labels, function type should be
6179 integer. Can't modify the type in place though, since it can be shared
6180 with other functions. For dummy arguments, the typing is done to
6181 this result, even if it has to be repeated for each call. */
6182 if (has_alternate_specifier
6183 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6185 if (!sym
->attr
.dummy
)
6187 TREE_TYPE (sym
->backend_decl
)
6188 = build_function_type (integer_type_node
,
6189 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6190 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6193 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6196 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6197 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6199 /* Allocatable scalar function results must be freed and nullified
6200 after use. This necessitates the creation of a temporary to
6201 hold the result to prevent duplicate calls. */
6202 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6203 && ((sym
->attr
.allocatable
&& !sym
->attr
.dimension
&& !comp
)
6204 || (comp
&& comp
->attr
.allocatable
&& !comp
->attr
.dimension
)))
6206 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6207 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6209 tmp
= gfc_call_free (tmp
);
6210 gfc_add_expr_to_block (&post
, tmp
);
6211 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6214 /* If we have a pointer function, but we don't want a pointer, e.g.
6217 where f is pointer valued, we have to dereference the result. */
6218 if (!se
->want_pointer
&& !byref
6219 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6220 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6221 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6223 /* f2c calling conventions require a scalar default real function to
6224 return a double precision result. Convert this back to default
6225 real. We only care about the cases that can happen in Fortran 77.
6227 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6228 && sym
->ts
.kind
== gfc_default_real_kind
6229 && !sym
->attr
.always_explicit
)
6230 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6232 /* A pure function may still have side-effects - it may modify its
6234 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6236 if (!sym
->attr
.pure
)
6237 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6242 /* Add the function call to the pre chain. There is no expression. */
6243 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6244 se
->expr
= NULL_TREE
;
6246 if (!se
->direct_byref
)
6248 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6250 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6252 /* Check the data pointer hasn't been modified. This would
6253 happen in a function returning a pointer. */
6254 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6255 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6258 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6261 se
->expr
= info
->descriptor
;
6262 /* Bundle in the string length. */
6263 se
->string_length
= len
;
6265 else if (ts
.type
== BT_CHARACTER
)
6267 /* Dereference for character pointer results. */
6268 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6269 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6270 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6274 se
->string_length
= len
;
6278 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6279 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6284 /* Associate the rhs class object's meta-data with the result, when the
6285 result is a temporary. */
6286 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6287 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6288 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6291 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6293 gfc_init_se (&parmse
, NULL
);
6294 parmse
.data_not_needed
= 1;
6295 gfc_conv_expr (&parmse
, class_expr
);
6296 if (!DECL_LANG_SPECIFIC (result
))
6297 gfc_allocate_lang_decl (result
);
6298 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6299 gfc_free_expr (class_expr
);
6300 gcc_assert (parmse
.pre
.head
== NULL_TREE
6301 && parmse
.post
.head
== NULL_TREE
);
6304 /* Follow the function call with the argument post block. */
6307 gfc_add_block_to_block (&se
->pre
, &post
);
6309 /* Transformational functions of derived types with allocatable
6310 components must have the result allocatable components copied when the
6311 argument is actually given. */
6312 arg
= expr
->value
.function
.actual
;
6313 if (result
&& arg
&& expr
->rank
6314 && expr
->value
.function
.isym
6315 && expr
->value
.function
.isym
->transformational
6317 && arg
->expr
->ts
.type
== BT_DERIVED
6318 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6321 /* Copy the allocatable components. We have to use a
6322 temporary here to prevent source allocatable components
6323 from being corrupted. */
6324 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6325 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6326 result
, tmp2
, expr
->rank
, 0);
6327 gfc_add_expr_to_block (&se
->pre
, tmp
);
6328 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6330 gfc_add_expr_to_block (&se
->pre
, tmp
);
6332 /* Finally free the temporary's data field. */
6333 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6334 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6335 NULL_TREE
, NULL_TREE
, true,
6336 NULL
, GFC_CAF_COARRAY_NOCOARRAY
);
6337 gfc_add_expr_to_block (&se
->pre
, tmp
);
6342 /* For a function with a class array result, save the result as
6343 a temporary, set the info fields needed by the scalarizer and
6344 call the finalization function of the temporary. Note that the
6345 nullification of allocatable components needed by the result
6346 is done in gfc_trans_assignment_1. */
6347 if (expr
&& ((gfc_is_class_array_function (expr
)
6348 && se
->ss
&& se
->ss
->loop
)
6349 || gfc_is_alloc_class_scalar_function (expr
))
6350 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6351 && expr
->must_finalize
)
6356 if (se
->ss
&& se
->ss
->loop
)
6358 gfc_add_block_to_block (&se
->ss
->loop
->pre
, &se
->pre
);
6359 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6360 tmp
= gfc_class_data_get (se
->expr
);
6361 info
->descriptor
= tmp
;
6362 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6363 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6364 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6366 tree dim
= gfc_rank_cst
[n
];
6367 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6368 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6373 /* TODO Eliminate the doubling of temporaries. This
6374 one is necessary to ensure no memory leakage. */
6375 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6376 tmp
= gfc_class_data_get (se
->expr
);
6377 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6378 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6381 if ((gfc_is_class_array_function (expr
)
6382 || gfc_is_alloc_class_scalar_function (expr
))
6383 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
)
6384 goto no_finalization
;
6386 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6387 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6390 fold_convert (TREE_TYPE (final_fndecl
),
6391 null_pointer_node
));
6392 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6394 tmp
= build_call_expr_loc (input_location
,
6396 gfc_build_addr_expr (NULL
, tmp
),
6397 gfc_class_vtab_size_get (se
->expr
),
6398 boolean_false_node
);
6399 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6400 void_type_node
, is_final
, tmp
,
6401 build_empty_stmt (input_location
));
6403 if (se
->ss
&& se
->ss
->loop
)
6405 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6406 tmp
= gfc_call_free (info
->data
);
6407 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6411 gfc_add_expr_to_block (&se
->post
, tmp
);
6412 tmp
= gfc_class_data_get (se
->expr
);
6413 tmp
= gfc_call_free (tmp
);
6414 gfc_add_expr_to_block (&se
->post
, tmp
);
6418 expr
->must_finalize
= 0;
6421 gfc_add_block_to_block (&se
->post
, &post
);
6424 return has_alternate_specifier
;
6428 /* Fill a character string with spaces. */
6431 fill_with_spaces (tree start
, tree type
, tree size
)
6433 stmtblock_t block
, loop
;
6434 tree i
, el
, exit_label
, cond
, tmp
;
6436 /* For a simple char type, we can call memset(). */
6437 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6438 return build_call_expr_loc (input_location
,
6439 builtin_decl_explicit (BUILT_IN_MEMSET
),
6441 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6442 lang_hooks
.to_target_charset (' ')),
6443 fold_convert (size_type_node
, size
));
6445 /* Otherwise, we use a loop:
6446 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6450 /* Initialize variables. */
6451 gfc_init_block (&block
);
6452 i
= gfc_create_var (sizetype
, "i");
6453 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6454 el
= gfc_create_var (build_pointer_type (type
), "el");
6455 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6456 exit_label
= gfc_build_label_decl (NULL_TREE
);
6457 TREE_USED (exit_label
) = 1;
6461 gfc_init_block (&loop
);
6463 /* Exit condition. */
6464 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, i
,
6465 build_zero_cst (sizetype
));
6466 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6467 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6468 build_empty_stmt (input_location
));
6469 gfc_add_expr_to_block (&loop
, tmp
);
6472 gfc_add_modify (&loop
,
6473 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6474 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6476 /* Increment loop variables. */
6477 gfc_add_modify (&loop
, i
,
6478 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6479 TYPE_SIZE_UNIT (type
)));
6480 gfc_add_modify (&loop
, el
,
6481 fold_build_pointer_plus_loc (input_location
,
6482 el
, TYPE_SIZE_UNIT (type
)));
6484 /* Making the loop... actually loop! */
6485 tmp
= gfc_finish_block (&loop
);
6486 tmp
= build1_v (LOOP_EXPR
, tmp
);
6487 gfc_add_expr_to_block (&block
, tmp
);
6489 /* The exit label. */
6490 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6491 gfc_add_expr_to_block (&block
, tmp
);
6494 return gfc_finish_block (&block
);
6498 /* Generate code to copy a string. */
6501 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6502 int dkind
, tree slength
, tree src
, int skind
)
6504 tree tmp
, dlen
, slen
;
6513 stmtblock_t tempblock
;
6515 gcc_assert (dkind
== skind
);
6517 if (slength
!= NULL_TREE
)
6519 slen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, slength
), block
);
6520 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6524 slen
= build_one_cst (gfc_charlen_type_node
);
6528 if (dlength
!= NULL_TREE
)
6530 dlen
= gfc_evaluate_now (fold_convert (gfc_charlen_type_node
, dlength
), block
);
6531 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6535 dlen
= build_one_cst (gfc_charlen_type_node
);
6539 /* Assign directly if the types are compatible. */
6540 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6541 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6543 gfc_add_modify (block
, dsc
, ssc
);
6547 /* The string copy algorithm below generates code like
6551 if (srclen < destlen)
6553 memmove (dest, src, srclen);
6555 memset (&dest[srclen], ' ', destlen - srclen);
6559 // Truncate if too long.
6560 memmove (dest, src, destlen);
6565 /* Do nothing if the destination length is zero. */
6566 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
, dlen
,
6567 build_zero_cst (TREE_TYPE (dlen
)));
6569 /* For non-default character kinds, we have to multiply the string
6570 length by the base type size. */
6571 chartype
= gfc_get_char_type (dkind
);
6572 slen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (slen
),
6574 fold_convert (TREE_TYPE (slen
),
6575 TYPE_SIZE_UNIT (chartype
)));
6576 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (dlen
),
6578 fold_convert (TREE_TYPE (dlen
),
6579 TYPE_SIZE_UNIT (chartype
)));
6581 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6582 dest
= fold_convert (pvoid_type_node
, dest
);
6584 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6586 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6587 src
= fold_convert (pvoid_type_node
, src
);
6589 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6591 /* Truncate string if source is too long. */
6592 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
, slen
,
6595 /* Copy and pad with spaces. */
6596 tmp3
= build_call_expr_loc (input_location
,
6597 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6599 fold_convert (size_type_node
, slen
));
6601 /* Wstringop-overflow appears at -O3 even though this warning is not
6602 explicitly available in fortran nor can it be switched off. If the
6603 source length is a constant, its negative appears as a very large
6604 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6605 the result of the MINUS_EXPR suppresses this spurious warning. */
6606 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6607 TREE_TYPE(dlen
), dlen
, slen
);
6608 if (slength
&& TREE_CONSTANT (slength
))
6609 tmp
= gfc_evaluate_now (tmp
, block
);
6611 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6612 tmp4
= fill_with_spaces (tmp4
, chartype
, tmp
);
6614 gfc_init_block (&tempblock
);
6615 gfc_add_expr_to_block (&tempblock
, tmp3
);
6616 gfc_add_expr_to_block (&tempblock
, tmp4
);
6617 tmp3
= gfc_finish_block (&tempblock
);
6619 /* The truncated memmove if the slen >= dlen. */
6620 tmp2
= build_call_expr_loc (input_location
,
6621 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6623 fold_convert (size_type_node
, dlen
));
6625 /* The whole copy_string function is there. */
6626 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6628 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6629 build_empty_stmt (input_location
));
6630 gfc_add_expr_to_block (block
, tmp
);
6634 /* Translate a statement function.
6635 The value of a statement function reference is obtained by evaluating the
6636 expression using the values of the actual arguments for the values of the
6637 corresponding dummy arguments. */
6640 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6644 gfc_formal_arglist
*fargs
;
6645 gfc_actual_arglist
*args
;
6648 gfc_saved_var
*saved_vars
;
6654 sym
= expr
->symtree
->n
.sym
;
6655 args
= expr
->value
.function
.actual
;
6656 gfc_init_se (&lse
, NULL
);
6657 gfc_init_se (&rse
, NULL
);
6660 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6662 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6663 temp_vars
= XCNEWVEC (tree
, n
);
6665 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6666 fargs
= fargs
->next
, n
++)
6668 /* Each dummy shall be specified, explicitly or implicitly, to be
6670 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6673 if (fsym
->ts
.type
== BT_CHARACTER
)
6675 /* Copy string arguments. */
6678 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6679 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6681 /* Create a temporary to hold the value. */
6682 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6683 fsym
->ts
.u
.cl
->backend_decl
6684 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6686 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6687 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6689 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6691 gfc_conv_expr (&rse
, args
->expr
);
6692 gfc_conv_string_parameter (&rse
);
6693 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6694 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6696 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6697 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6698 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6699 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6703 /* For everything else, just evaluate the expression. */
6705 /* Create a temporary to hold the value. */
6706 type
= gfc_typenode_for_spec (&fsym
->ts
);
6707 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6709 gfc_conv_expr (&lse
, args
->expr
);
6711 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6712 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6713 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6719 /* Use the temporary variables in place of the real ones. */
6720 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6721 fargs
= fargs
->next
, n
++)
6722 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6724 gfc_conv_expr (se
, sym
->value
);
6726 if (sym
->ts
.type
== BT_CHARACTER
)
6728 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6730 /* Force the expression to the correct length. */
6731 if (!INTEGER_CST_P (se
->string_length
)
6732 || tree_int_cst_lt (se
->string_length
,
6733 sym
->ts
.u
.cl
->backend_decl
))
6735 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6736 tmp
= gfc_create_var (type
, sym
->name
);
6737 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6738 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6739 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6743 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6746 /* Restore the original variables. */
6747 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6748 fargs
= fargs
->next
, n
++)
6749 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6755 /* Translate a function expression. */
6758 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6762 if (expr
->value
.function
.isym
)
6764 gfc_conv_intrinsic_function (se
, expr
);
6768 /* expr.value.function.esym is the resolved (specific) function symbol for
6769 most functions. However this isn't set for dummy procedures. */
6770 sym
= expr
->value
.function
.esym
;
6772 sym
= expr
->symtree
->n
.sym
;
6774 /* The IEEE_ARITHMETIC functions are caught here. */
6775 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6776 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6779 /* We distinguish statement functions from general functions to improve
6780 runtime performance. */
6781 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6783 gfc_conv_statement_function (se
, expr
);
6787 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6792 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6795 is_zero_initializer_p (gfc_expr
* expr
)
6797 if (expr
->expr_type
!= EXPR_CONSTANT
)
6800 /* We ignore constants with prescribed memory representations for now. */
6801 if (expr
->representation
.string
)
6804 switch (expr
->ts
.type
)
6807 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6810 return mpfr_zero_p (expr
->value
.real
)
6811 && MPFR_SIGN (expr
->value
.real
) >= 0;
6814 return expr
->value
.logical
== 0;
6817 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6818 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6819 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6820 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6830 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6835 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6836 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6838 gfc_conv_tmp_array_ref (se
);
6842 /* Build a static initializer. EXPR is the expression for the initial value.
6843 The other parameters describe the variable of the component being
6844 initialized. EXPR may be null. */
6847 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6848 bool array
, bool pointer
, bool procptr
)
6852 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6853 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6854 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6855 return build_constructor (type
, NULL
);
6857 if (!(expr
|| pointer
|| procptr
))
6860 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6861 (these are the only two iso_c_binding derived types that can be
6862 used as initialization expressions). If so, we need to modify
6863 the 'expr' to be that for a (void *). */
6864 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6865 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6867 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6869 /* The derived symbol has already been converted to a (void *). Use
6871 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6872 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6874 gfc_init_se (&se
, NULL
);
6875 gfc_conv_constant (&se
, expr
);
6876 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6880 if (array
&& !procptr
)
6883 /* Arrays need special handling. */
6885 ctor
= gfc_build_null_descriptor (type
);
6886 /* Special case assigning an array to zero. */
6887 else if (is_zero_initializer_p (expr
))
6888 ctor
= build_constructor (type
, NULL
);
6890 ctor
= gfc_conv_array_initializer (type
, expr
);
6891 TREE_STATIC (ctor
) = 1;
6894 else if (pointer
|| procptr
)
6896 if (ts
->type
== BT_CLASS
&& !procptr
)
6898 gfc_init_se (&se
, NULL
);
6899 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6900 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6901 TREE_STATIC (se
.expr
) = 1;
6904 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6905 return fold_convert (type
, null_pointer_node
);
6908 gfc_init_se (&se
, NULL
);
6909 se
.want_pointer
= 1;
6910 gfc_conv_expr (&se
, expr
);
6911 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6921 gfc_init_se (&se
, NULL
);
6922 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6923 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6925 gfc_conv_structure (&se
, expr
, 1);
6926 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6927 TREE_STATIC (se
.expr
) = 1;
6932 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6933 TREE_STATIC (ctor
) = 1;
6938 gfc_init_se (&se
, NULL
);
6939 gfc_conv_constant (&se
, expr
);
6940 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6947 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6953 gfc_array_info
*lss_array
;
6960 gfc_start_block (&block
);
6962 /* Initialize the scalarizer. */
6963 gfc_init_loopinfo (&loop
);
6965 gfc_init_se (&lse
, NULL
);
6966 gfc_init_se (&rse
, NULL
);
6969 rss
= gfc_walk_expr (expr
);
6970 if (rss
== gfc_ss_terminator
)
6971 /* The rhs is scalar. Add a ss for the expression. */
6972 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6974 /* Create a SS for the destination. */
6975 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6977 lss_array
= &lss
->info
->data
.array
;
6978 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6979 lss_array
->descriptor
= dest
;
6980 lss_array
->data
= gfc_conv_array_data (dest
);
6981 lss_array
->offset
= gfc_conv_array_offset (dest
);
6982 for (n
= 0; n
< cm
->as
->rank
; n
++)
6984 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6985 lss_array
->stride
[n
] = gfc_index_one_node
;
6987 mpz_init (lss_array
->shape
[n
]);
6988 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6989 cm
->as
->lower
[n
]->value
.integer
);
6990 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6993 /* Associate the SS with the loop. */
6994 gfc_add_ss_to_loop (&loop
, lss
);
6995 gfc_add_ss_to_loop (&loop
, rss
);
6997 /* Calculate the bounds of the scalarization. */
6998 gfc_conv_ss_startstride (&loop
);
7000 /* Setup the scalarizing loops. */
7001 gfc_conv_loop_setup (&loop
, &expr
->where
);
7003 /* Setup the gfc_se structures. */
7004 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7005 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7008 gfc_mark_ss_chain_used (rss
, 1);
7010 gfc_mark_ss_chain_used (lss
, 1);
7012 /* Start the scalarized loop body. */
7013 gfc_start_scalarized_body (&loop
, &body
);
7015 gfc_conv_tmp_array_ref (&lse
);
7016 if (cm
->ts
.type
== BT_CHARACTER
)
7017 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7019 gfc_conv_expr (&rse
, expr
);
7021 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
7022 gfc_add_expr_to_block (&body
, tmp
);
7024 gcc_assert (rse
.ss
== gfc_ss_terminator
);
7026 /* Generate the copying loops. */
7027 gfc_trans_scalarizing_loops (&loop
, &body
);
7029 /* Wrap the whole thing up. */
7030 gfc_add_block_to_block (&block
, &loop
.pre
);
7031 gfc_add_block_to_block (&block
, &loop
.post
);
7033 gcc_assert (lss_array
->shape
!= NULL
);
7034 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
7035 gfc_cleanup_loop (&loop
);
7037 return gfc_finish_block (&block
);
7042 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
7052 gfc_expr
*arg
= NULL
;
7054 gfc_start_block (&block
);
7055 gfc_init_se (&se
, NULL
);
7057 /* Get the descriptor for the expressions. */
7058 se
.want_pointer
= 0;
7059 gfc_conv_expr_descriptor (&se
, expr
);
7060 gfc_add_block_to_block (&block
, &se
.pre
);
7061 gfc_add_modify (&block
, dest
, se
.expr
);
7063 /* Deal with arrays of derived types with allocatable components. */
7064 if (gfc_bt_struct (cm
->ts
.type
)
7065 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
7066 // TODO: Fix caf_mode
7067 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
7070 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
7071 && CLASS_DATA(cm
)->attr
.allocatable
)
7073 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
7074 // TODO: Fix caf_mode
7075 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
7080 tmp
= TREE_TYPE (dest
);
7081 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7082 tmp
, expr
->rank
, NULL_TREE
);
7086 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
7087 TREE_TYPE(cm
->backend_decl
),
7088 cm
->as
->rank
, NULL_TREE
);
7090 gfc_add_expr_to_block (&block
, tmp
);
7091 gfc_add_block_to_block (&block
, &se
.post
);
7093 if (expr
->expr_type
!= EXPR_VARIABLE
)
7094 gfc_conv_descriptor_data_set (&block
, se
.expr
,
7097 /* We need to know if the argument of a conversion function is a
7098 variable, so that the correct lower bound can be used. */
7099 if (expr
->expr_type
== EXPR_FUNCTION
7100 && expr
->value
.function
.isym
7101 && expr
->value
.function
.isym
->conversion
7102 && expr
->value
.function
.actual
->expr
7103 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
7104 arg
= expr
->value
.function
.actual
->expr
;
7106 /* Obtain the array spec of full array references. */
7108 as
= gfc_get_full_arrayspec_from_expr (arg
);
7110 as
= gfc_get_full_arrayspec_from_expr (expr
);
7112 /* Shift the lbound and ubound of temporaries to being unity,
7113 rather than zero, based. Always calculate the offset. */
7114 offset
= gfc_conv_descriptor_offset_get (dest
);
7115 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
7116 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
7118 for (n
= 0; n
< expr
->rank
; n
++)
7123 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7124 TODO It looks as if gfc_conv_expr_descriptor should return
7125 the correct bounds and that the following should not be
7126 necessary. This would simplify gfc_conv_intrinsic_bound
7128 if (as
&& as
->lower
[n
])
7131 gfc_init_se (&lbse
, NULL
);
7132 gfc_conv_expr (&lbse
, as
->lower
[n
]);
7133 gfc_add_block_to_block (&block
, &lbse
.pre
);
7134 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
7138 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7139 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7143 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7146 lbound
= gfc_index_one_node
;
7148 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7150 /* Shift the bounds and set the offset accordingly. */
7151 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7152 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7153 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7154 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7156 gfc_conv_descriptor_ubound_set (&block
, dest
,
7157 gfc_rank_cst
[n
], tmp
);
7158 gfc_conv_descriptor_lbound_set (&block
, dest
,
7159 gfc_rank_cst
[n
], lbound
);
7161 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7162 gfc_conv_descriptor_lbound_get (dest
,
7164 gfc_conv_descriptor_stride_get (dest
,
7166 gfc_add_modify (&block
, tmp2
, tmp
);
7167 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7169 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7174 /* If a conversion expression has a null data pointer
7175 argument, nullify the allocatable component. */
7179 if (arg
->symtree
->n
.sym
->attr
.allocatable
7180 || arg
->symtree
->n
.sym
->attr
.pointer
)
7182 non_null_expr
= gfc_finish_block (&block
);
7183 gfc_start_block (&block
);
7184 gfc_conv_descriptor_data_set (&block
, dest
,
7186 null_expr
= gfc_finish_block (&block
);
7187 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7188 tmp
= build2_loc (input_location
, EQ_EXPR
, logical_type_node
, tmp
,
7189 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7190 return build3_v (COND_EXPR
, tmp
,
7191 null_expr
, non_null_expr
);
7195 return gfc_finish_block (&block
);
7199 /* Allocate or reallocate scalar component, as necessary. */
7202 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7212 tree lhs_cl_size
= NULL_TREE
;
7217 if (!expr2
|| expr2
->rank
)
7220 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7222 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7224 char name
[GFC_MAX_SYMBOL_LEN
+9];
7225 gfc_component
*strlen
;
7226 /* Use the rhs string length and the lhs element size. */
7227 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7228 if (!expr2
->ts
.u
.cl
->backend_decl
)
7230 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7231 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7234 size
= expr2
->ts
.u
.cl
->backend_decl
;
7236 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7238 sprintf (name
, "_%s_length", cm
->name
);
7239 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7240 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7241 gfc_charlen_type_node
,
7242 TREE_OPERAND (comp
, 0),
7243 strlen
->backend_decl
, NULL_TREE
);
7245 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7246 tmp
= TYPE_SIZE_UNIT (tmp
);
7247 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7248 TREE_TYPE (tmp
), tmp
,
7249 fold_convert (TREE_TYPE (tmp
), size
));
7251 else if (cm
->ts
.type
== BT_CLASS
)
7253 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7254 if (expr2
->ts
.type
== BT_DERIVED
)
7256 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7257 size
= TYPE_SIZE_UNIT (tmp
);
7263 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7264 gfc_add_vptr_component (e2vtab
);
7265 gfc_add_size_component (e2vtab
);
7266 gfc_init_se (&se
, NULL
);
7267 gfc_conv_expr (&se
, e2vtab
);
7268 gfc_add_block_to_block (block
, &se
.pre
);
7269 size
= fold_convert (size_type_node
, se
.expr
);
7270 gfc_free_expr (e2vtab
);
7272 size_in_bytes
= size
;
7276 /* Otherwise use the length in bytes of the rhs. */
7277 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7278 size_in_bytes
= size
;
7281 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7282 size_in_bytes
, size_one_node
);
7284 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7286 tmp
= build_call_expr_loc (input_location
,
7287 builtin_decl_explicit (BUILT_IN_CALLOC
),
7288 2, build_one_cst (size_type_node
),
7290 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7291 gfc_add_modify (block
, comp
, tmp
);
7295 tmp
= build_call_expr_loc (input_location
,
7296 builtin_decl_explicit (BUILT_IN_MALLOC
),
7298 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7299 ptr
= gfc_class_data_get (comp
);
7302 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7303 gfc_add_modify (block
, ptr
, tmp
);
7306 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7307 /* Update the lhs character length. */
7308 gfc_add_modify (block
, lhs_cl_size
,
7309 fold_convert (TREE_TYPE (lhs_cl_size
), size
));
7313 /* Assign a single component of a derived type constructor. */
7316 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7317 gfc_symbol
*sym
, bool init
)
7325 gfc_start_block (&block
);
7327 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7329 /* Only care about pointers here, not about allocatables. */
7330 gfc_init_se (&se
, NULL
);
7331 /* Pointer component. */
7332 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7333 && !cm
->attr
.proc_pointer
)
7335 /* Array pointer. */
7336 if (expr
->expr_type
== EXPR_NULL
)
7337 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7340 se
.direct_byref
= 1;
7342 gfc_conv_expr_descriptor (&se
, expr
);
7343 gfc_add_block_to_block (&block
, &se
.pre
);
7344 gfc_add_block_to_block (&block
, &se
.post
);
7349 /* Scalar pointers. */
7350 se
.want_pointer
= 1;
7351 gfc_conv_expr (&se
, expr
);
7352 gfc_add_block_to_block (&block
, &se
.pre
);
7354 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7355 && expr
->symtree
->n
.sym
->attr
.dummy
)
7356 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7358 gfc_add_modify (&block
, dest
,
7359 fold_convert (TREE_TYPE (dest
), se
.expr
));
7360 gfc_add_block_to_block (&block
, &se
.post
);
7363 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7365 /* NULL initialization for CLASS components. */
7366 tmp
= gfc_trans_structure_assign (dest
,
7367 gfc_class_initializer (&cm
->ts
, expr
),
7369 gfc_add_expr_to_block (&block
, tmp
);
7371 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7372 && !cm
->attr
.proc_pointer
)
7374 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7375 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7376 else if (cm
->attr
.allocatable
|| cm
->attr
.pdt_array
)
7378 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7379 gfc_add_expr_to_block (&block
, tmp
);
7383 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7384 gfc_add_expr_to_block (&block
, tmp
);
7387 else if (cm
->ts
.type
== BT_CLASS
7388 && CLASS_DATA (cm
)->attr
.dimension
7389 && CLASS_DATA (cm
)->attr
.allocatable
7390 && expr
->ts
.type
== BT_DERIVED
)
7392 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7393 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7394 tmp
= gfc_class_vptr_get (dest
);
7395 gfc_add_modify (&block
, tmp
,
7396 fold_convert (TREE_TYPE (tmp
), vtab
));
7397 tmp
= gfc_class_data_get (dest
);
7398 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7399 gfc_add_expr_to_block (&block
, tmp
);
7401 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7403 /* NULL initialization for allocatable components. */
7404 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7405 null_pointer_node
));
7407 else if (init
&& (cm
->attr
.allocatable
7408 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7409 && expr
->ts
.type
!= BT_CLASS
)))
7411 /* Take care about non-array allocatable components here. The alloc_*
7412 routine below is motivated by the alloc_scalar_allocatable_for_
7413 assignment() routine, but with the realloc portions removed and
7415 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7420 /* The remainder of these instructions follow the if (cm->attr.pointer)
7421 if (!cm->attr.dimension) part above. */
7422 gfc_init_se (&se
, NULL
);
7423 gfc_conv_expr (&se
, expr
);
7424 gfc_add_block_to_block (&block
, &se
.pre
);
7426 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7427 && expr
->symtree
->n
.sym
->attr
.dummy
)
7428 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7430 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7432 tmp
= gfc_class_data_get (dest
);
7433 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7434 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7435 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7436 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7437 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7440 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7442 /* For deferred strings insert a memcpy. */
7443 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7446 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7447 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7449 : expr
->ts
.u
.cl
->backend_decl
);
7450 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7451 gfc_add_expr_to_block (&block
, tmp
);
7454 gfc_add_modify (&block
, tmp
,
7455 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7456 gfc_add_block_to_block (&block
, &se
.post
);
7458 else if (expr
->ts
.type
== BT_UNION
)
7461 gfc_constructor
*c
= gfc_constructor_first (expr
->value
.constructor
);
7462 /* We mark that the entire union should be initialized with a contrived
7463 EXPR_NULL expression at the beginning. */
7464 if (c
!= NULL
&& c
->n
.component
== NULL
7465 && c
->expr
!= NULL
&& c
->expr
->expr_type
== EXPR_NULL
)
7467 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7468 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
7469 gfc_add_expr_to_block (&block
, tmp
);
7470 c
= gfc_constructor_next (c
);
7472 /* The following constructor expression, if any, represents a specific
7473 map intializer, as given by the user. */
7474 if (c
!= NULL
&& c
->expr
!= NULL
)
7476 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7477 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7478 gfc_add_expr_to_block (&block
, tmp
);
7481 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7483 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7485 tree dealloc
= NULL_TREE
;
7486 gfc_init_se (&se
, NULL
);
7487 gfc_conv_expr (&se
, expr
);
7488 gfc_add_block_to_block (&block
, &se
.pre
);
7489 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7490 expression in a temporary variable and deallocate the allocatable
7491 components. Then we can the copy the expression to the result. */
7492 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7493 && expr
->expr_type
!= EXPR_VARIABLE
)
7495 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7496 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7499 gfc_add_modify (&block
, dest
,
7500 fold_convert (TREE_TYPE (dest
), se
.expr
));
7501 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7502 && expr
->expr_type
!= EXPR_NULL
)
7504 // TODO: Fix caf_mode
7505 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7506 dest
, expr
->rank
, 0);
7507 gfc_add_expr_to_block (&block
, tmp
);
7508 if (dealloc
!= NULL_TREE
)
7509 gfc_add_expr_to_block (&block
, dealloc
);
7511 gfc_add_block_to_block (&block
, &se
.post
);
7515 /* Nested constructors. */
7516 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7517 gfc_add_expr_to_block (&block
, tmp
);
7520 else if (gfc_deferred_strlen (cm
, &tmp
))
7524 gcc_assert (strlen
);
7525 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7527 TREE_OPERAND (dest
, 0),
7530 if (expr
->expr_type
== EXPR_NULL
)
7532 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7533 gfc_add_modify (&block
, dest
, tmp
);
7534 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7535 gfc_add_modify (&block
, strlen
, tmp
);
7540 gfc_init_se (&se
, NULL
);
7541 gfc_conv_expr (&se
, expr
);
7542 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7543 tmp
= build_call_expr_loc (input_location
,
7544 builtin_decl_explicit (BUILT_IN_MALLOC
),
7546 gfc_add_modify (&block
, dest
,
7547 fold_convert (TREE_TYPE (dest
), tmp
));
7548 gfc_add_modify (&block
, strlen
,
7549 fold_convert (TREE_TYPE (strlen
), se
.string_length
));
7550 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7551 gfc_add_expr_to_block (&block
, tmp
);
7554 else if (!cm
->attr
.artificial
)
7556 /* Scalar component (excluding deferred parameters). */
7557 gfc_init_se (&se
, NULL
);
7558 gfc_init_se (&lse
, NULL
);
7560 gfc_conv_expr (&se
, expr
);
7561 if (cm
->ts
.type
== BT_CHARACTER
)
7562 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7564 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7565 gfc_add_expr_to_block (&block
, tmp
);
7567 return gfc_finish_block (&block
);
7570 /* Assign a derived type constructor to a variable. */
7573 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
, bool coarray
)
7582 gfc_start_block (&block
);
7583 cm
= expr
->ts
.u
.derived
->components
;
7585 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7586 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7587 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7591 gfc_init_se (&se
, NULL
);
7592 gfc_init_se (&lse
, NULL
);
7593 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7595 gfc_add_modify (&block
, lse
.expr
,
7596 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7598 return gfc_finish_block (&block
);
7602 gfc_init_se (&se
, NULL
);
7604 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7605 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7607 /* Skip absent members in default initializers. */
7608 if (!c
->expr
&& !cm
->attr
.allocatable
)
7611 /* Register the component with the caf-lib before it is initialized.
7612 Register only allocatable components, that are not coarray'ed
7613 components (%comp[*]). Only register when the constructor is not the
7615 if (coarray
&& !cm
->attr
.codimension
7616 && (cm
->attr
.allocatable
|| cm
->attr
.pointer
)
7617 && (!c
->expr
|| c
->expr
->expr_type
== EXPR_NULL
))
7619 tree token
, desc
, size
;
7620 bool is_array
= cm
->ts
.type
== BT_CLASS
7621 ? CLASS_DATA (cm
)->attr
.dimension
: cm
->attr
.dimension
;
7623 field
= cm
->backend_decl
;
7624 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
7625 TREE_TYPE (field
), dest
, field
, NULL_TREE
);
7626 if (cm
->ts
.type
== BT_CLASS
)
7627 field
= gfc_class_data_get (field
);
7629 token
= is_array
? gfc_conv_descriptor_token (field
)
7630 : fold_build3_loc (input_location
, COMPONENT_REF
,
7631 TREE_TYPE (cm
->caf_token
), dest
,
7632 cm
->caf_token
, NULL_TREE
);
7636 /* The _caf_register routine looks at the rank of the array
7637 descriptor to decide whether the data registered is an array
7639 int rank
= cm
->ts
.type
== BT_CLASS
? CLASS_DATA (cm
)->as
->rank
7641 /* When the rank is not known just set a positive rank, which
7642 suffices to recognize the data as array. */
7645 size
= integer_zero_node
;
7647 gfc_add_modify (&block
, gfc_conv_descriptor_rank (desc
),
7648 build_int_cst (signed_char_type_node
, rank
));
7652 desc
= gfc_conv_scalar_to_descriptor (&se
, field
,
7653 cm
->ts
.type
== BT_CLASS
7654 ? CLASS_DATA (cm
)->attr
7656 size
= TYPE_SIZE_UNIT (TREE_TYPE (field
));
7658 gfc_add_block_to_block (&block
, &se
.pre
);
7659 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
,
7660 7, size
, build_int_cst (
7662 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY
),
7663 gfc_build_addr_expr (pvoid_type_node
,
7665 gfc_build_addr_expr (NULL_TREE
, desc
),
7666 null_pointer_node
, null_pointer_node
,
7668 gfc_add_expr_to_block (&block
, tmp
);
7670 field
= cm
->backend_decl
;
7671 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7672 dest
, field
, NULL_TREE
);
7675 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7676 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7681 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7682 expr
->ts
.u
.derived
, init
);
7683 gfc_add_expr_to_block (&block
, tmp
);
7685 return gfc_finish_block (&block
);
7689 gfc_conv_union_initializer (vec
<constructor_elt
, va_gc
> *v
,
7690 gfc_component
*un
, gfc_expr
*init
)
7692 gfc_constructor
*ctor
;
7694 if (un
->ts
.type
!= BT_UNION
|| un
== NULL
|| init
== NULL
)
7697 ctor
= gfc_constructor_first (init
->value
.constructor
);
7699 if (ctor
== NULL
|| ctor
->expr
== NULL
)
7702 gcc_assert (init
->expr_type
== EXPR_STRUCTURE
);
7704 /* If we have an 'initialize all' constructor, do it first. */
7705 if (ctor
->expr
->expr_type
== EXPR_NULL
)
7707 tree union_type
= TREE_TYPE (un
->backend_decl
);
7708 tree val
= build_constructor (union_type
, NULL
);
7709 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7710 ctor
= gfc_constructor_next (ctor
);
7713 /* Add the map initializer on top. */
7714 if (ctor
!= NULL
&& ctor
->expr
!= NULL
)
7716 gcc_assert (ctor
->expr
->expr_type
== EXPR_STRUCTURE
);
7717 tree val
= gfc_conv_initializer (ctor
->expr
, &un
->ts
,
7718 TREE_TYPE (un
->backend_decl
),
7719 un
->attr
.dimension
, un
->attr
.pointer
,
7720 un
->attr
.proc_pointer
);
7721 CONSTRUCTOR_APPEND_ELT (v
, un
->backend_decl
, val
);
7725 /* Build an expression for a constructor. If init is nonzero then
7726 this is part of a static variable initializer. */
7729 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7736 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7738 gcc_assert (se
->ss
== NULL
);
7739 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7740 type
= gfc_typenode_for_spec (&expr
->ts
);
7744 /* Create a temporary variable and fill it in. */
7745 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7746 /* The symtree in expr is NULL, if the code to generate is for
7747 initializing the static members only. */
7748 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
,
7750 gfc_add_expr_to_block (&se
->pre
, tmp
);
7754 cm
= expr
->ts
.u
.derived
->components
;
7756 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7757 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7759 /* Skip absent members in default initializers and allocatable
7760 components. Although the latter have a default initializer
7761 of EXPR_NULL,... by default, the static nullify is not needed
7762 since this is done every time we come into scope. */
7763 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7766 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7767 && strcmp (cm
->name
, "_extends") == 0
7768 && cm
->initializer
->symtree
)
7772 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7773 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7774 vtab
= unshare_expr_without_location (vtab
);
7775 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7777 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7779 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7780 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7781 fold_convert (TREE_TYPE (cm
->backend_decl
),
7784 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7785 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7786 fold_convert (TREE_TYPE (cm
->backend_decl
),
7787 integer_zero_node
));
7788 else if (cm
->ts
.type
== BT_UNION
)
7789 gfc_conv_union_initializer (v
, cm
, c
->expr
);
7792 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7793 TREE_TYPE (cm
->backend_decl
),
7794 cm
->attr
.dimension
, cm
->attr
.pointer
,
7795 cm
->attr
.proc_pointer
);
7796 val
= unshare_expr_without_location (val
);
7798 /* Append it to the constructor list. */
7799 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7803 se
->expr
= build_constructor (type
, v
);
7805 TREE_CONSTANT (se
->expr
) = 1;
7809 /* Translate a substring expression. */
7812 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7818 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7820 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7821 expr
->value
.character
.length
,
7822 expr
->value
.character
.string
);
7824 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7825 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7828 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7832 /* Entry point for expression translation. Evaluates a scalar quantity.
7833 EXPR is the expression to be translated, and SE is the state structure if
7834 called from within the scalarized. */
7837 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7842 if (ss
&& ss
->info
->expr
== expr
7843 && (ss
->info
->type
== GFC_SS_SCALAR
7844 || ss
->info
->type
== GFC_SS_REFERENCE
))
7846 gfc_ss_info
*ss_info
;
7849 /* Substitute a scalar expression evaluated outside the scalarization
7851 se
->expr
= ss_info
->data
.scalar
.value
;
7852 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7853 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7855 se
->string_length
= ss_info
->string_length
;
7856 gfc_advance_se_ss_chain (se
);
7860 /* We need to convert the expressions for the iso_c_binding derived types.
7861 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7862 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7863 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7864 updated to be an integer with a kind equal to the size of a (void *). */
7865 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7866 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7868 if (expr
->expr_type
== EXPR_VARIABLE
7869 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7870 || expr
->symtree
->n
.sym
->intmod_sym_id
7871 == ISOCBINDING_NULL_FUNPTR
))
7873 /* Set expr_type to EXPR_NULL, which will result in
7874 null_pointer_node being used below. */
7875 expr
->expr_type
= EXPR_NULL
;
7879 /* Update the type/kind of the expression to be what the new
7880 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7881 expr
->ts
.type
= BT_INTEGER
;
7882 expr
->ts
.f90_type
= BT_VOID
;
7883 expr
->ts
.kind
= gfc_index_integer_kind
;
7887 gfc_fix_class_refs (expr
);
7889 switch (expr
->expr_type
)
7892 gfc_conv_expr_op (se
, expr
);
7896 gfc_conv_function_expr (se
, expr
);
7900 gfc_conv_constant (se
, expr
);
7904 gfc_conv_variable (se
, expr
);
7908 se
->expr
= null_pointer_node
;
7911 case EXPR_SUBSTRING
:
7912 gfc_conv_substring_expr (se
, expr
);
7915 case EXPR_STRUCTURE
:
7916 gfc_conv_structure (se
, expr
, 0);
7920 gfc_conv_array_constructor_expr (se
, expr
);
7929 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7930 of an assignment. */
7932 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7934 gfc_conv_expr (se
, expr
);
7935 /* All numeric lvalues should have empty post chains. If not we need to
7936 figure out a way of rewriting an lvalue so that it has no post chain. */
7937 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7940 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7941 numeric expressions. Used for scalar values where inserting cleanup code
7944 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7948 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7949 gfc_conv_expr (se
, expr
);
7952 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7953 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7955 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7959 /* Helper to translate an expression and convert it to a particular type. */
7961 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7963 gfc_conv_expr_val (se
, expr
);
7964 se
->expr
= convert (type
, se
->expr
);
7968 /* Converts an expression so that it can be passed by reference. Scalar
7972 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7978 if (ss
&& ss
->info
->expr
== expr
7979 && ss
->info
->type
== GFC_SS_REFERENCE
)
7981 /* Returns a reference to the scalar evaluated outside the loop
7983 gfc_conv_expr (se
, expr
);
7985 if (expr
->ts
.type
== BT_CHARACTER
7986 && expr
->expr_type
!= EXPR_FUNCTION
)
7987 gfc_conv_string_parameter (se
);
7989 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7994 if (expr
->ts
.type
== BT_CHARACTER
)
7996 gfc_conv_expr (se
, expr
);
7997 gfc_conv_string_parameter (se
);
8001 if (expr
->expr_type
== EXPR_VARIABLE
)
8003 se
->want_pointer
= 1;
8004 gfc_conv_expr (se
, expr
);
8007 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8008 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8009 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8015 if (expr
->expr_type
== EXPR_FUNCTION
8016 && ((expr
->value
.function
.esym
8017 && expr
->value
.function
.esym
->result
->attr
.pointer
8018 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
8019 || (!expr
->value
.function
.esym
&& !expr
->ref
8020 && expr
->symtree
->n
.sym
->attr
.pointer
8021 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
8023 se
->want_pointer
= 1;
8024 gfc_conv_expr (se
, expr
);
8025 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8026 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8031 gfc_conv_expr (se
, expr
);
8033 /* Create a temporary var to hold the value. */
8034 if (TREE_CONSTANT (se
->expr
))
8036 tree tmp
= se
->expr
;
8037 STRIP_TYPE_NOPS (tmp
);
8038 var
= build_decl (input_location
,
8039 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
8040 DECL_INITIAL (var
) = tmp
;
8041 TREE_STATIC (var
) = 1;
8046 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
8047 gfc_add_modify (&se
->pre
, var
, se
->expr
);
8049 gfc_add_block_to_block (&se
->pre
, &se
->post
);
8051 /* Take the address of that value. */
8052 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
8056 /* Get the _len component for an unlimited polymorphic expression. */
8059 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
8062 gfc_ref
*ref
= expr
->ref
;
8064 gfc_init_se (&se
, NULL
);
8065 while (ref
&& ref
->next
)
8067 gfc_add_len_component (expr
);
8068 gfc_conv_expr (&se
, expr
);
8069 gfc_add_block_to_block (block
, &se
.pre
);
8070 gcc_assert (se
.post
.head
== NULL_TREE
);
8073 gfc_free_ref_list (ref
->next
);
8078 gfc_free_ref_list (expr
->ref
);
8085 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8086 statement-list outside of the scalarizer-loop. When code is generated, that
8087 depends on the scalarized expression, it is added to RSE.PRE.
8088 Returns le's _vptr tree and when set the len expressions in to_lenp and
8089 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8093 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
8094 gfc_expr
* re
, gfc_se
*rse
,
8095 tree
* to_lenp
, tree
* from_lenp
)
8098 gfc_expr
* vptr_expr
;
8099 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
8100 bool set_vptr
= false, temp_rhs
= false;
8101 stmtblock_t
*pre
= block
;
8103 /* Create a temporary for complicated expressions. */
8104 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
8105 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
8107 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
8109 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
8114 /* Get the _vptr for the left-hand side expression. */
8115 gfc_init_se (&se
, NULL
);
8116 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
8117 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
8119 /* Care about _len for unlimited polymorphic entities. */
8120 if (UNLIMITED_POLY (vptr_expr
)
8121 || (vptr_expr
->ts
.type
== BT_DERIVED
8122 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8123 to_len
= trans_get_upoly_len (block
, vptr_expr
);
8124 gfc_add_vptr_component (vptr_expr
);
8128 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8129 se
.want_pointer
= 1;
8130 gfc_conv_expr (&se
, vptr_expr
);
8131 gfc_free_expr (vptr_expr
);
8132 gfc_add_block_to_block (block
, &se
.pre
);
8133 gcc_assert (se
.post
.head
== NULL_TREE
);
8135 STRIP_NOPS (lhs_vptr
);
8137 /* Set the _vptr only when the left-hand side of the assignment is a
8141 /* Get the vptr from the rhs expression only, when it is variable.
8142 Functions are expected to be assigned to a temporary beforehand. */
8143 vptr_expr
= (re
->expr_type
== EXPR_VARIABLE
&& re
->ts
.type
== BT_CLASS
)
8144 ? gfc_find_and_cut_at_last_class_ref (re
)
8146 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
8148 if (to_len
!= NULL_TREE
)
8150 /* Get the _len information from the rhs. */
8151 if (UNLIMITED_POLY (vptr_expr
)
8152 || (vptr_expr
->ts
.type
== BT_DERIVED
8153 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
8154 from_len
= trans_get_upoly_len (block
, vptr_expr
);
8156 gfc_add_vptr_component (vptr_expr
);
8160 if (re
->expr_type
== EXPR_VARIABLE
8161 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
8162 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
8163 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
8164 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8165 re
->symtree
->n
.sym
->backend_decl
))))
8168 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8169 re
->symtree
->n
.sym
->backend_decl
));
8171 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8172 re
->symtree
->n
.sym
->backend_decl
));
8174 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
8177 se
.expr
= gfc_class_vptr_get (rse
->expr
);
8178 if (UNLIMITED_POLY (re
))
8179 from_len
= gfc_class_len_get (rse
->expr
);
8181 else if (re
->expr_type
!= EXPR_NULL
)
8182 /* Only when rhs is non-NULL use its declared type for vptr
8184 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
8186 /* When the rhs is NULL use the vtab of lhs' declared type. */
8187 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
8192 gfc_init_se (&se
, NULL
);
8193 se
.want_pointer
= 1;
8194 gfc_conv_expr (&se
, vptr_expr
);
8195 gfc_free_expr (vptr_expr
);
8196 gfc_add_block_to_block (block
, &se
.pre
);
8197 gcc_assert (se
.post
.head
== NULL_TREE
);
8199 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
8202 if (to_len
!= NULL_TREE
)
8204 /* The _len component needs to be set. Figure how to get the
8205 value of the right-hand side. */
8206 if (from_len
== NULL_TREE
)
8208 if (rse
->string_length
!= NULL_TREE
)
8209 from_len
= rse
->string_length
;
8210 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
8212 from_len
= gfc_get_expr_charlen (re
);
8213 gfc_init_se (&se
, NULL
);
8214 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
8215 gfc_add_block_to_block (block
, &se
.pre
);
8216 gcc_assert (se
.post
.head
== NULL_TREE
);
8217 from_len
= gfc_evaluate_now (se
.expr
, block
);
8220 from_len
= build_zero_cst (gfc_charlen_type_node
);
8222 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
8227 /* Return the _len trees only, when requested. */
8231 *from_lenp
= from_len
;
8236 /* Assign tokens for pointer components. */
8239 trans_caf_token_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_expr
*expr1
,
8242 symbol_attribute lhs_attr
, rhs_attr
;
8243 tree tmp
, lhs_tok
, rhs_tok
;
8244 /* Flag to indicated component refs on the rhs. */
8247 lhs_attr
= gfc_caf_attr (expr1
);
8248 if (expr2
->expr_type
!= EXPR_NULL
)
8250 rhs_attr
= gfc_caf_attr (expr2
, false, &rhs_cr
);
8251 if (lhs_attr
.codimension
&& rhs_attr
.codimension
)
8253 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8254 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8257 rhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (rse
, expr2
);
8261 caf_decl
= gfc_get_tree_for_caf_expr (expr2
);
8262 gfc_get_caf_token_offset (rse
, &rhs_tok
, NULL
, caf_decl
,
8265 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8267 fold_convert (TREE_TYPE (lhs_tok
), rhs_tok
));
8268 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8271 else if (lhs_attr
.codimension
)
8273 lhs_tok
= gfc_get_ultimate_alloc_ptr_comps_caf_token (lse
, expr1
);
8274 lhs_tok
= build_fold_indirect_ref (lhs_tok
);
8275 tmp
= build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8276 lhs_tok
, null_pointer_node
);
8277 gfc_prepend_expr_to_block (&lse
->post
, tmp
);
8281 /* Indentify class valued proc_pointer assignments. */
8284 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
8289 while (ref
&& ref
->next
)
8292 return ref
&& ref
->type
== REF_COMPONENT
8293 && ref
->u
.c
.component
->attr
.proc_pointer
8294 && expr2
->expr_type
== EXPR_VARIABLE
8295 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8299 /* Do everything that is needed for a CLASS function expr2. */
8302 trans_class_pointer_fcn (stmtblock_t
*block
, gfc_se
*lse
, gfc_se
*rse
,
8303 gfc_expr
*expr1
, gfc_expr
*expr2
)
8305 tree expr1_vptr
= NULL_TREE
;
8308 gfc_conv_function_expr (rse
, expr2
);
8309 rse
->expr
= gfc_evaluate_now (rse
->expr
, &rse
->pre
);
8311 if (expr1
->ts
.type
!= BT_CLASS
)
8312 rse
->expr
= gfc_class_data_get (rse
->expr
);
8315 expr1_vptr
= trans_class_vptr_len_assignment (block
, expr1
,
8318 gfc_add_block_to_block (block
, &rse
->pre
);
8319 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "ptrtemp");
8320 gfc_add_modify (&lse
->pre
, tmp
, rse
->expr
);
8322 gfc_add_modify (&lse
->pre
, expr1_vptr
,
8323 fold_convert (TREE_TYPE (expr1_vptr
),
8324 gfc_class_vptr_get (tmp
)));
8325 rse
->expr
= gfc_class_data_get (tmp
);
8333 gfc_trans_pointer_assign (gfc_code
* code
)
8335 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8339 /* Generate code for a pointer assignment. */
8342 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8349 tree expr1_vptr
= NULL_TREE
;
8350 bool scalar
, non_proc_pointer_assign
;
8353 gfc_start_block (&block
);
8355 gfc_init_se (&lse
, NULL
);
8357 /* Usually testing whether this is not a proc pointer assignment. */
8358 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8360 /* Check whether the expression is a scalar or not; we cannot use
8361 expr1->rank as it can be nonzero for proc pointers. */
8362 ss
= gfc_walk_expr (expr1
);
8363 scalar
= ss
== gfc_ss_terminator
;
8365 gfc_free_ss_chain (ss
);
8367 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8368 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8370 gfc_add_data_component (expr2
);
8371 /* The following is required as gfc_add_data_component doesn't
8372 update ts.type if there is a tailing REF_ARRAY. */
8373 expr2
->ts
.type
= BT_DERIVED
;
8378 /* Scalar pointers. */
8379 lse
.want_pointer
= 1;
8380 gfc_conv_expr (&lse
, expr1
);
8381 gfc_init_se (&rse
, NULL
);
8382 rse
.want_pointer
= 1;
8383 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8384 trans_class_pointer_fcn (&block
, &lse
, &rse
, expr1
, expr2
);
8386 gfc_conv_expr (&rse
, expr2
);
8388 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8390 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8392 lse
.expr
= gfc_class_data_get (lse
.expr
);
8395 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8396 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8397 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8400 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8401 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8402 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8405 gfc_add_block_to_block (&block
, &lse
.pre
);
8406 gfc_add_block_to_block (&block
, &rse
.pre
);
8408 /* Check character lengths if character expression. The test is only
8409 really added if -fbounds-check is enabled. Exclude deferred
8410 character length lefthand sides. */
8411 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8412 && !expr1
->ts
.deferred
8413 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8414 && !gfc_is_proc_ptr_comp (expr1
))
8416 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8417 gcc_assert (lse
.string_length
&& rse
.string_length
);
8418 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8419 lse
.string_length
, rse
.string_length
,
8423 /* The assignment to an deferred character length sets the string
8424 length to that of the rhs. */
8425 if (expr1
->ts
.deferred
)
8427 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8428 gfc_add_modify (&block
, lse
.string_length
,
8429 fold_convert (TREE_TYPE (lse
.string_length
),
8430 rse
.string_length
));
8431 else if (lse
.string_length
!= NULL
)
8432 gfc_add_modify (&block
, lse
.string_length
,
8433 build_zero_cst (TREE_TYPE (lse
.string_length
)));
8436 gfc_add_modify (&block
, lse
.expr
,
8437 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8439 /* Also set the tokens for pointer components in derived typed
8441 if (flag_coarray
== GFC_FCOARRAY_LIB
)
8442 trans_caf_token_assign (&lse
, &rse
, expr1
, expr2
);
8444 gfc_add_block_to_block (&block
, &rse
.post
);
8445 gfc_add_block_to_block (&block
, &lse
.post
);
8452 tree strlen_rhs
= NULL_TREE
;
8454 /* Array pointer. Find the last reference on the LHS and if it is an
8455 array section ref, we're dealing with bounds remapping. In this case,
8456 set it to AR_FULL so that gfc_conv_expr_descriptor does
8457 not see it and process the bounds remapping afterwards explicitly. */
8458 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8459 if (!remap
->next
&& remap
->type
== REF_ARRAY
8460 && remap
->u
.ar
.type
== AR_SECTION
)
8462 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8464 gfc_init_se (&lse
, NULL
);
8466 lse
.descriptor_only
= 1;
8467 gfc_conv_expr_descriptor (&lse
, expr1
);
8468 strlen_lhs
= lse
.string_length
;
8471 if (expr2
->expr_type
== EXPR_NULL
)
8473 /* Just set the data pointer to null. */
8474 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8476 else if (rank_remap
)
8478 /* If we are rank-remapping, just get the RHS's descriptor and
8479 process this later on. */
8480 gfc_init_se (&rse
, NULL
);
8481 rse
.direct_byref
= 1;
8482 rse
.byref_noassign
= 1;
8484 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8485 expr1_vptr
= trans_class_pointer_fcn (&block
, &lse
, &rse
,
8487 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8489 tree bound
[GFC_MAX_DIMENSIONS
];
8492 for (i
= 0; i
< expr2
->rank
; i
++)
8493 bound
[i
] = NULL_TREE
;
8494 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8495 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8497 GFC_ARRAY_POINTER_CONT
, false);
8498 tmp
= gfc_create_var (tmp
, "ptrtemp");
8499 rse
.descriptor_only
= 0;
8501 rse
.direct_byref
= 1;
8502 gfc_conv_expr_descriptor (&rse
, expr2
);
8503 strlen_rhs
= rse
.string_length
;
8508 gfc_conv_expr_descriptor (&rse
, expr2
);
8509 strlen_rhs
= rse
.string_length
;
8510 if (expr1
->ts
.type
== BT_CLASS
)
8511 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8516 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8518 /* Assign directly to the LHS's descriptor. */
8519 lse
.descriptor_only
= 0;
8520 lse
.direct_byref
= 1;
8521 gfc_conv_expr_descriptor (&lse
, expr2
);
8522 strlen_rhs
= lse
.string_length
;
8524 if (expr1
->ts
.type
== BT_CLASS
)
8526 rse
.expr
= NULL_TREE
;
8527 rse
.string_length
= NULL_TREE
;
8528 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8534 /* If the target is not a whole array, use the target array
8535 reference for remap. */
8536 for (remap
= expr2
->ref
; remap
; remap
= remap
->next
)
8537 if (remap
->type
== REF_ARRAY
8538 && remap
->u
.ar
.type
== AR_FULL
8543 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8545 gfc_init_se (&rse
, NULL
);
8546 rse
.want_pointer
= 1;
8547 gfc_conv_function_expr (&rse
, expr2
);
8548 if (expr1
->ts
.type
!= BT_CLASS
)
8550 rse
.expr
= gfc_class_data_get (rse
.expr
);
8551 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8552 /* Set the lhs span. */
8553 tmp
= TREE_TYPE (rse
.expr
);
8554 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8555 tmp
= fold_convert (gfc_array_index_type
, tmp
);
8556 gfc_conv_descriptor_span_set (&lse
.pre
, desc
, tmp
);
8560 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8563 gfc_add_block_to_block (&block
, &rse
.pre
);
8564 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8565 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8567 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8568 fold_convert (TREE_TYPE (expr1_vptr
),
8569 gfc_class_vptr_get (tmp
)));
8570 rse
.expr
= gfc_class_data_get (tmp
);
8571 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8576 /* Assign to a temporary descriptor and then copy that
8577 temporary to the pointer. */
8578 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8579 lse
.descriptor_only
= 0;
8581 lse
.direct_byref
= 1;
8582 gfc_conv_expr_descriptor (&lse
, expr2
);
8583 strlen_rhs
= lse
.string_length
;
8584 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8587 gfc_add_block_to_block (&block
, &lse
.pre
);
8589 gfc_add_block_to_block (&block
, &rse
.pre
);
8591 /* If we do bounds remapping, update LHS descriptor accordingly. */
8595 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8599 /* Do rank remapping. We already have the RHS's descriptor
8600 converted in rse and now have to build the correct LHS
8601 descriptor for it. */
8603 tree dtype
, data
, span
;
8605 tree lbound
, ubound
;
8608 dtype
= gfc_conv_descriptor_dtype (desc
);
8609 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8610 gfc_add_modify (&block
, dtype
, tmp
);
8612 /* Copy data pointer. */
8613 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8614 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8616 /* Copy the span. */
8617 if (TREE_CODE (rse
.expr
) == VAR_DECL
8618 && GFC_DECL_PTR_ARRAY_P (rse
.expr
))
8619 span
= gfc_conv_descriptor_span_get (rse
.expr
);
8622 tmp
= TREE_TYPE (rse
.expr
);
8623 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (tmp
));
8624 span
= fold_convert (gfc_array_index_type
, tmp
);
8626 gfc_conv_descriptor_span_set (&block
, desc
, span
);
8628 /* Copy offset but adjust it such that it would correspond
8629 to a lbound of zero. */
8630 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8631 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8633 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8635 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8637 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8638 gfc_array_index_type
, stride
, lbound
);
8639 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8640 gfc_array_index_type
, offs
, tmp
);
8642 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8644 /* Set the bounds as declared for the LHS and calculate strides as
8645 well as another offset update accordingly. */
8646 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8648 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8653 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8655 /* Convert declared bounds. */
8656 gfc_init_se (&lower_se
, NULL
);
8657 gfc_init_se (&upper_se
, NULL
);
8658 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8659 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8661 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8662 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8664 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8665 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8667 lbound
= gfc_evaluate_now (lbound
, &block
);
8668 ubound
= gfc_evaluate_now (ubound
, &block
);
8670 gfc_add_block_to_block (&block
, &lower_se
.post
);
8671 gfc_add_block_to_block (&block
, &upper_se
.post
);
8673 /* Set bounds in descriptor. */
8674 gfc_conv_descriptor_lbound_set (&block
, desc
,
8675 gfc_rank_cst
[dim
], lbound
);
8676 gfc_conv_descriptor_ubound_set (&block
, desc
,
8677 gfc_rank_cst
[dim
], ubound
);
8680 stride
= gfc_evaluate_now (stride
, &block
);
8681 gfc_conv_descriptor_stride_set (&block
, desc
,
8682 gfc_rank_cst
[dim
], stride
);
8684 /* Update offset. */
8685 offs
= gfc_conv_descriptor_offset_get (desc
);
8686 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8687 gfc_array_index_type
, lbound
, stride
);
8688 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8689 gfc_array_index_type
, offs
, tmp
);
8690 offs
= gfc_evaluate_now (offs
, &block
);
8691 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8693 /* Update stride. */
8694 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8695 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8696 gfc_array_index_type
, stride
, tmp
);
8701 /* Bounds remapping. Just shift the lower bounds. */
8703 gcc_assert (expr1
->rank
== expr2
->rank
);
8705 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8709 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8710 gfc_init_se (&lbound_se
, NULL
);
8711 if (remap
->u
.ar
.start
[dim
])
8713 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8714 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8717 /* This remap arises from a target that is not a whole
8718 array. The start expressions will be NULL but we need
8719 the lbounds to be one. */
8720 lbound_se
.expr
= gfc_index_one_node
;
8721 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8722 dim
, lbound_se
.expr
);
8723 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8728 /* Check string lengths if applicable. The check is only really added
8729 to the output code if -fbounds-check is enabled. */
8730 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8732 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8733 gcc_assert (strlen_lhs
&& strlen_rhs
);
8734 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8735 strlen_lhs
, strlen_rhs
, &block
);
8738 /* If rank remapping was done, check with -fcheck=bounds that
8739 the target is at least as large as the pointer. */
8740 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8746 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8747 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8749 lsize
= gfc_evaluate_now (lsize
, &block
);
8750 rsize
= gfc_evaluate_now (rsize
, &block
);
8751 fault
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
8754 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8755 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8759 gfc_add_block_to_block (&block
, &lse
.post
);
8761 gfc_add_block_to_block (&block
, &rse
.post
);
8764 return gfc_finish_block (&block
);
8768 /* Makes sure se is suitable for passing as a function string parameter. */
8769 /* TODO: Need to check all callers of this function. It may be abused. */
8772 gfc_conv_string_parameter (gfc_se
* se
)
8776 if (TREE_CODE (se
->expr
) == STRING_CST
)
8778 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8779 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8783 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8785 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8787 type
= TREE_TYPE (se
->expr
);
8788 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8792 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8794 type
= build_pointer_type (type
);
8795 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8799 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8803 /* Generate code for assignment of scalar variables. Includes character
8804 strings and derived types with allocatable components.
8805 If you know that the LHS has no allocations, set dealloc to false.
8807 DEEP_COPY has no effect if the typespec TS is not a derived type with
8808 allocatable components. Otherwise, if it is set, an explicit copy of each
8809 allocatable component is made. This is necessary as a simple copy of the
8810 whole object would copy array descriptors as is, so that the lhs's
8811 allocatable components would point to the rhs's after the assignment.
8812 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8813 necessary if the rhs is a non-pointer function, as the allocatable components
8814 are not accessible by other means than the function's result after the
8815 function has returned. It is even more subtle when temporaries are involved,
8816 as the two following examples show:
8817 1. When we evaluate an array constructor, a temporary is created. Thus
8818 there is theoretically no alias possible. However, no deep copy is
8819 made for this temporary, so that if the constructor is made of one or
8820 more variable with allocatable components, those components still point
8821 to the variable's: DEEP_COPY should be set for the assignment from the
8822 temporary to the lhs in that case.
8823 2. When assigning a scalar to an array, we evaluate the scalar value out
8824 of the loop, store it into a temporary variable, and assign from that.
8825 In that case, deep copying when assigning to the temporary would be a
8826 waste of resources; however deep copies should happen when assigning from
8827 the temporary to each array element: again DEEP_COPY should be set for
8828 the assignment from the temporary to the lhs. */
8831 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8832 bool deep_copy
, bool dealloc
, bool in_coarray
)
8838 gfc_init_block (&block
);
8840 if (ts
.type
== BT_CHARACTER
)
8845 if (lse
->string_length
!= NULL_TREE
)
8847 gfc_conv_string_parameter (lse
);
8848 gfc_add_block_to_block (&block
, &lse
->pre
);
8849 llen
= lse
->string_length
;
8852 if (rse
->string_length
!= NULL_TREE
)
8854 gfc_conv_string_parameter (rse
);
8855 gfc_add_block_to_block (&block
, &rse
->pre
);
8856 rlen
= rse
->string_length
;
8859 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8860 rse
->expr
, ts
.kind
);
8862 else if (gfc_bt_struct (ts
.type
)
8863 && (ts
.u
.derived
->attr
.alloc_comp
8864 || (deep_copy
&& ts
.u
.derived
->attr
.pdt_type
)))
8866 tree tmp_var
= NULL_TREE
;
8869 /* Are the rhs and the lhs the same? */
8872 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
8873 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8874 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8875 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8878 /* Deallocate the lhs allocated components as long as it is not
8879 the same as the rhs. This must be done following the assignment
8880 to prevent deallocating data that could be used in the rhs
8884 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8885 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8887 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8889 gfc_add_expr_to_block (&lse
->post
, tmp
);
8892 gfc_add_block_to_block (&block
, &rse
->pre
);
8893 gfc_add_block_to_block (&block
, &lse
->pre
);
8895 gfc_add_modify (&block
, lse
->expr
,
8896 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8898 /* Restore pointer address of coarray components. */
8899 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8901 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8902 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8904 gfc_add_expr_to_block (&block
, tmp
);
8907 /* Do a deep copy if the rhs is a variable, if it is not the
8911 int caf_mode
= in_coarray
? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8912 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
) : 0;
8913 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0,
8915 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8917 gfc_add_expr_to_block (&block
, tmp
);
8920 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8922 gfc_add_block_to_block (&block
, &lse
->pre
);
8923 gfc_add_block_to_block (&block
, &rse
->pre
);
8924 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8925 TREE_TYPE (lse
->expr
), rse
->expr
);
8926 gfc_add_modify (&block
, lse
->expr
, tmp
);
8930 gfc_add_block_to_block (&block
, &lse
->pre
);
8931 gfc_add_block_to_block (&block
, &rse
->pre
);
8933 gfc_add_modify (&block
, lse
->expr
,
8934 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8937 gfc_add_block_to_block (&block
, &lse
->post
);
8938 gfc_add_block_to_block (&block
, &rse
->post
);
8940 return gfc_finish_block (&block
);
8944 /* There are quite a lot of restrictions on the optimisation in using an
8945 array function assign without a temporary. */
8948 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8951 bool seen_array_ref
;
8953 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8955 /* Play it safe with class functions assigned to a derived type. */
8956 if (gfc_is_class_array_function (expr2
)
8957 && expr1
->ts
.type
== BT_DERIVED
)
8960 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8961 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8964 /* Elemental functions are scalarized so that they don't need a
8965 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8966 they would need special treatment in gfc_trans_arrayfunc_assign. */
8967 if (expr2
->value
.function
.esym
!= NULL
8968 && expr2
->value
.function
.esym
->attr
.elemental
)
8971 /* Need a temporary if rhs is not FULL or a contiguous section. */
8972 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8975 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8976 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8979 /* Functions returning pointers or allocatables need temporaries. */
8980 c
= expr2
->value
.function
.esym
8981 ? (expr2
->value
.function
.esym
->attr
.pointer
8982 || expr2
->value
.function
.esym
->attr
.allocatable
)
8983 : (expr2
->symtree
->n
.sym
->attr
.pointer
8984 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8988 /* Character array functions need temporaries unless the
8989 character lengths are the same. */
8990 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8992 if (expr1
->ts
.u
.cl
->length
== NULL
8993 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8996 if (expr2
->ts
.u
.cl
->length
== NULL
8997 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
9000 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
9001 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
9005 /* Check that no LHS component references appear during an array
9006 reference. This is needed because we do not have the means to
9007 span any arbitrary stride with an array descriptor. This check
9008 is not needed for the rhs because the function result has to be
9010 seen_array_ref
= false;
9011 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9013 if (ref
->type
== REF_ARRAY
)
9014 seen_array_ref
= true;
9015 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
9019 /* Check for a dependency. */
9020 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
9021 expr2
->value
.function
.esym
,
9022 expr2
->value
.function
.actual
,
9026 /* If we have reached here with an intrinsic function, we do not
9027 need a temporary except in the particular case that reallocation
9028 on assignment is active and the lhs is allocatable and a target. */
9029 if (expr2
->value
.function
.isym
)
9030 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
9032 /* If the LHS is a dummy, we need a temporary if it is not
9034 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
9037 /* If the lhs has been host_associated, is in common, a pointer or is
9038 a target and the function is not using a RESULT variable, aliasing
9039 can occur and a temporary is needed. */
9040 if ((sym
->attr
.host_assoc
9041 || sym
->attr
.in_common
9042 || sym
->attr
.pointer
9043 || sym
->attr
.cray_pointee
9044 || sym
->attr
.target
)
9045 && expr2
->symtree
!= NULL
9046 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
9049 /* A PURE function can unconditionally be called without a temporary. */
9050 if (expr2
->value
.function
.esym
!= NULL
9051 && expr2
->value
.function
.esym
->attr
.pure
)
9054 /* Implicit_pure functions are those which could legally be declared
9056 if (expr2
->value
.function
.esym
!= NULL
9057 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
9060 if (!sym
->attr
.use_assoc
9061 && !sym
->attr
.in_common
9062 && !sym
->attr
.pointer
9063 && !sym
->attr
.target
9064 && !sym
->attr
.cray_pointee
9065 && expr2
->value
.function
.esym
)
9067 /* A temporary is not needed if the function is not contained and
9068 the variable is local or host associated and not a pointer or
9070 if (!expr2
->value
.function
.esym
->attr
.contained
)
9073 /* A temporary is not needed if the lhs has never been host
9074 associated and the procedure is contained. */
9075 else if (!sym
->attr
.host_assoc
)
9078 /* A temporary is not needed if the variable is local and not
9079 a pointer, a target or a result. */
9081 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
9085 /* Default to temporary use. */
9090 /* Provide the loop info so that the lhs descriptor can be built for
9091 reallocatable assignments from extrinsic function calls. */
9094 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
9097 /* Signal that the function call should not be made by
9098 gfc_conv_loop_setup. */
9099 se
->ss
->is_alloc_lhs
= 1;
9100 gfc_init_loopinfo (loop
);
9101 gfc_add_ss_to_loop (loop
, *ss
);
9102 gfc_add_ss_to_loop (loop
, se
->ss
);
9103 gfc_conv_ss_startstride (loop
);
9104 gfc_conv_loop_setup (loop
, where
);
9105 gfc_copy_loopinfo_to_se (se
, loop
);
9106 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
9107 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
9108 se
->ss
->is_alloc_lhs
= 0;
9112 /* For assignment to a reallocatable lhs from intrinsic functions,
9113 replace the se.expr (ie. the result) with a temporary descriptor.
9114 Null the data field so that the library allocates space for the
9115 result. Free the data of the original descriptor after the function,
9116 in case it appears in an argument expression and transfer the
9117 result to the original descriptor. */
9120 fcncall_realloc_result (gfc_se
*se
, int rank
)
9129 /* Use the allocation done by the library. Substitute the lhs
9130 descriptor with a copy, whose data field is nulled.*/
9131 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
9132 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
9133 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
9135 /* Unallocated, the descriptor does not have a dtype. */
9136 tmp
= gfc_conv_descriptor_dtype (desc
);
9137 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
9139 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
9140 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
9141 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
9143 /* Free the lhs after the function call and copy the result data to
9144 the lhs descriptor. */
9145 tmp
= gfc_conv_descriptor_data_get (desc
);
9146 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
9147 logical_type_node
, tmp
,
9148 build_int_cst (TREE_TYPE (tmp
), 0));
9149 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9150 tmp
= gfc_call_free (tmp
);
9151 gfc_add_expr_to_block (&se
->post
, tmp
);
9153 tmp
= gfc_conv_descriptor_data_get (res_desc
);
9154 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
9156 /* Check that the shapes are the same between lhs and expression. */
9157 for (n
= 0 ; n
< rank
; n
++)
9160 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9161 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
9162 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9163 gfc_array_index_type
, tmp
, tmp1
);
9164 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
9165 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
9166 gfc_array_index_type
, tmp
, tmp1
);
9167 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9168 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9169 gfc_array_index_type
, tmp
, tmp1
);
9170 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
9171 logical_type_node
, tmp
,
9172 gfc_index_zero_node
);
9173 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
9174 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
9175 logical_type_node
, tmp
,
9179 /* 'zero_cond' being true is equal to lhs not being allocated or the
9180 shapes being different. */
9181 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
9183 /* Now reset the bounds returned from the function call to bounds based
9184 on the lhs lbounds, except where the lhs is not allocated or the shapes
9185 of 'variable and 'expr' are different. Set the offset accordingly. */
9186 offset
= gfc_index_zero_node
;
9187 for (n
= 0 ; n
< rank
; n
++)
9191 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
9192 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
9193 gfc_array_index_type
, zero_cond
,
9194 gfc_index_one_node
, lbound
);
9195 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
9197 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
9198 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
9199 gfc_array_index_type
, tmp
, lbound
);
9200 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
9201 gfc_rank_cst
[n
], lbound
);
9202 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
9203 gfc_rank_cst
[n
], tmp
);
9205 /* Set stride and accumulate the offset. */
9206 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
9207 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
9208 gfc_rank_cst
[n
], tmp
);
9209 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
9210 gfc_array_index_type
, lbound
, tmp
);
9211 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
9212 gfc_array_index_type
, offset
, tmp
);
9213 offset
= gfc_evaluate_now (offset
, &se
->post
);
9216 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
9221 /* Try to translate array(:) = func (...), where func is a transformational
9222 array function, without using a temporary. Returns NULL if this isn't the
9226 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
9230 gfc_component
*comp
= NULL
;
9233 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
9236 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9238 comp
= gfc_get_proc_ptr_comp (expr2
);
9239 gcc_assert (expr2
->value
.function
.isym
9240 || (comp
&& comp
->attr
.dimension
)
9241 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
9242 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
9244 gfc_init_se (&se
, NULL
);
9245 gfc_start_block (&se
.pre
);
9246 se
.want_pointer
= 1;
9248 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
9250 if (expr1
->ts
.type
== BT_DERIVED
9251 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9254 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
9256 gfc_add_expr_to_block (&se
.pre
, tmp
);
9259 se
.direct_byref
= 1;
9260 se
.ss
= gfc_walk_expr (expr2
);
9261 gcc_assert (se
.ss
!= gfc_ss_terminator
);
9263 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9264 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9265 Clearly, this cannot be done for an allocatable function result, since
9266 the shape of the result is unknown and, in any case, the function must
9267 correctly take care of the reallocation internally. For intrinsic
9268 calls, the array data is freed and the library takes care of allocation.
9269 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9271 if (flag_realloc_lhs
9272 && gfc_is_reallocatable_lhs (expr1
)
9273 && !gfc_expr_attr (expr1
).codimension
9274 && !gfc_is_coindexed (expr1
)
9275 && !(expr2
->value
.function
.esym
9276 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
9278 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9280 if (!expr2
->value
.function
.isym
)
9282 ss
= gfc_walk_expr (expr1
);
9283 gcc_assert (ss
!= gfc_ss_terminator
);
9285 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
9286 ss
->is_alloc_lhs
= 1;
9289 fcncall_realloc_result (&se
, expr1
->rank
);
9292 gfc_conv_function_expr (&se
, expr2
);
9293 gfc_add_block_to_block (&se
.pre
, &se
.post
);
9296 gfc_cleanup_loop (&loop
);
9298 gfc_free_ss_chain (se
.ss
);
9300 return gfc_finish_block (&se
.pre
);
9304 /* Try to efficiently translate array(:) = 0. Return NULL if this
9308 gfc_trans_zero_assign (gfc_expr
* expr
)
9310 tree dest
, len
, type
;
9314 sym
= expr
->symtree
->n
.sym
;
9315 dest
= gfc_get_symbol_decl (sym
);
9317 type
= TREE_TYPE (dest
);
9318 if (POINTER_TYPE_P (type
))
9319 type
= TREE_TYPE (type
);
9320 if (!GFC_ARRAY_TYPE_P (type
))
9323 /* Determine the length of the array. */
9324 len
= GFC_TYPE_ARRAY_SIZE (type
);
9325 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9328 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
9329 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9330 fold_convert (gfc_array_index_type
, tmp
));
9332 /* If we are zeroing a local array avoid taking its address by emitting
9334 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
9335 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
9336 dest
, build_constructor (TREE_TYPE (dest
),
9339 /* Convert arguments to the correct types. */
9340 dest
= fold_convert (pvoid_type_node
, dest
);
9341 len
= fold_convert (size_type_node
, len
);
9343 /* Construct call to __builtin_memset. */
9344 tmp
= build_call_expr_loc (input_location
,
9345 builtin_decl_explicit (BUILT_IN_MEMSET
),
9346 3, dest
, integer_zero_node
, len
);
9347 return fold_convert (void_type_node
, tmp
);
9351 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9352 that constructs the call to __builtin_memcpy. */
9355 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9359 /* Convert arguments to the correct types. */
9360 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9361 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9363 dst
= fold_convert (pvoid_type_node
, dst
);
9365 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9366 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9368 src
= fold_convert (pvoid_type_node
, src
);
9370 len
= fold_convert (size_type_node
, len
);
9372 /* Construct call to __builtin_memcpy. */
9373 tmp
= build_call_expr_loc (input_location
,
9374 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9376 return fold_convert (void_type_node
, tmp
);
9380 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9381 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9382 source/rhs, both are gfc_full_array_ref_p which have been checked for
9386 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9388 tree dst
, dlen
, dtype
;
9389 tree src
, slen
, stype
;
9392 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9393 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9395 dtype
= TREE_TYPE (dst
);
9396 if (POINTER_TYPE_P (dtype
))
9397 dtype
= TREE_TYPE (dtype
);
9398 stype
= TREE_TYPE (src
);
9399 if (POINTER_TYPE_P (stype
))
9400 stype
= TREE_TYPE (stype
);
9402 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9405 /* Determine the lengths of the arrays. */
9406 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9407 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9409 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9410 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9411 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9413 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9414 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9416 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9417 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9418 slen
, fold_convert (gfc_array_index_type
, tmp
));
9420 /* Sanity check that they are the same. This should always be
9421 the case, as we should already have checked for conformance. */
9422 if (!tree_int_cst_equal (slen
, dlen
))
9425 return gfc_build_memcpy_call (dst
, src
, dlen
);
9429 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9430 this can't be done. EXPR1 is the destination/lhs for which
9431 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9434 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9436 unsigned HOST_WIDE_INT nelem
;
9442 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9446 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9447 dtype
= TREE_TYPE (dst
);
9448 if (POINTER_TYPE_P (dtype
))
9449 dtype
= TREE_TYPE (dtype
);
9450 if (!GFC_ARRAY_TYPE_P (dtype
))
9453 /* Determine the lengths of the array. */
9454 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9455 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9458 /* Confirm that the constructor is the same size. */
9459 if (compare_tree_int (len
, nelem
) != 0)
9462 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9463 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9464 fold_convert (gfc_array_index_type
, tmp
));
9466 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9467 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9469 stype
= TREE_TYPE (src
);
9470 if (POINTER_TYPE_P (stype
))
9471 stype
= TREE_TYPE (stype
);
9473 return gfc_build_memcpy_call (dst
, src
, len
);
9477 /* Tells whether the expression is to be treated as a variable reference. */
9480 gfc_expr_is_variable (gfc_expr
*expr
)
9483 gfc_component
*comp
;
9484 gfc_symbol
*func_ifc
;
9486 if (expr
->expr_type
== EXPR_VARIABLE
)
9489 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9492 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9493 return gfc_expr_is_variable (arg
);
9496 /* A data-pointer-returning function should be considered as a variable
9498 if (expr
->expr_type
== EXPR_FUNCTION
9499 && expr
->ref
== NULL
)
9501 if (expr
->value
.function
.isym
!= NULL
)
9504 if (expr
->value
.function
.esym
!= NULL
)
9506 func_ifc
= expr
->value
.function
.esym
;
9511 gcc_assert (expr
->symtree
);
9512 func_ifc
= expr
->symtree
->n
.sym
;
9519 comp
= gfc_get_proc_ptr_comp (expr
);
9520 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9523 func_ifc
= comp
->ts
.interface
;
9527 if (expr
->expr_type
== EXPR_COMPCALL
)
9529 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9530 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9537 gcc_assert (func_ifc
->attr
.function
9538 && func_ifc
->result
!= NULL
);
9539 return func_ifc
->result
->attr
.pointer
;
9543 /* Is the lhs OK for automatic reallocation? */
9546 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9550 /* An allocatable variable with no reference. */
9551 if (expr
->symtree
->n
.sym
->attr
.allocatable
9555 /* All that can be left are allocatable components. However, we do
9556 not check for allocatable components here because the expression
9557 could be an allocatable component of a pointer component. */
9558 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9559 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9562 /* Find an allocatable component ref last. */
9563 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9564 if (ref
->type
== REF_COMPONENT
9566 && ref
->u
.c
.component
->attr
.allocatable
)
9573 /* Allocate or reallocate scalar lhs, as necessary. */
9576 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9591 if (!expr1
|| expr1
->rank
)
9594 if (!expr2
|| expr2
->rank
)
9597 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9598 if (ref
->type
== REF_SUBSTRING
)
9601 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9603 /* Since this is a scalar lhs, we can afford to do this. That is,
9604 there is no risk of side effects being repeated. */
9605 gfc_init_se (&lse
, NULL
);
9606 lse
.want_pointer
= 1;
9607 gfc_conv_expr (&lse
, expr1
);
9609 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9610 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9612 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9613 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9614 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
9616 tmp
= build3_v (COND_EXPR
, cond
,
9617 build1_v (GOTO_EXPR
, jump_label1
),
9618 build_empty_stmt (input_location
));
9619 gfc_add_expr_to_block (block
, tmp
);
9621 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9623 /* Use the rhs string length and the lhs element size. */
9624 size
= string_length
;
9625 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9626 tmp
= TYPE_SIZE_UNIT (tmp
);
9627 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9628 TREE_TYPE (tmp
), tmp
,
9629 fold_convert (TREE_TYPE (tmp
), size
));
9633 /* Otherwise use the length in bytes of the rhs. */
9634 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9635 size_in_bytes
= size
;
9638 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9639 size_in_bytes
, size_one_node
);
9641 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9643 tree caf_decl
, token
;
9645 symbol_attribute attr
;
9647 gfc_clear_attr (&attr
);
9648 gfc_init_se (&caf_se
, NULL
);
9650 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9651 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9653 gfc_add_block_to_block (block
, &caf_se
.pre
);
9654 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9655 gfc_build_addr_expr (NULL_TREE
, token
),
9656 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9659 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9661 tmp
= build_call_expr_loc (input_location
,
9662 builtin_decl_explicit (BUILT_IN_CALLOC
),
9663 2, build_one_cst (size_type_node
),
9665 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9666 gfc_add_modify (block
, lse
.expr
, tmp
);
9670 tmp
= build_call_expr_loc (input_location
,
9671 builtin_decl_explicit (BUILT_IN_MALLOC
),
9673 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9674 gfc_add_modify (block
, lse
.expr
, tmp
);
9677 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9679 /* Deferred characters need checking for lhs and rhs string
9680 length. Other deferred parameter variables will have to
9682 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9683 gfc_add_expr_to_block (block
, tmp
);
9685 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9686 gfc_add_expr_to_block (block
, tmp
);
9688 /* For a deferred length character, reallocate if lengths of lhs and
9689 rhs are different. */
9690 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9692 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
9694 fold_convert (TREE_TYPE (lse
.string_length
),
9696 /* Jump past the realloc if the lengths are the same. */
9697 tmp
= build3_v (COND_EXPR
, cond
,
9698 build1_v (GOTO_EXPR
, jump_label2
),
9699 build_empty_stmt (input_location
));
9700 gfc_add_expr_to_block (block
, tmp
);
9701 tmp
= build_call_expr_loc (input_location
,
9702 builtin_decl_explicit (BUILT_IN_REALLOC
),
9703 2, fold_convert (pvoid_type_node
, lse
.expr
),
9705 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9706 gfc_add_modify (block
, lse
.expr
, tmp
);
9707 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9708 gfc_add_expr_to_block (block
, tmp
);
9710 /* Update the lhs character length. */
9711 size
= string_length
;
9712 gfc_add_modify (block
, lse
.string_length
,
9713 fold_convert (TREE_TYPE (lse
.string_length
), size
));
9717 /* Check for assignments of the type
9721 to make sure we do not check for reallocation unneccessarily. */
9725 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9727 gfc_actual_arglist
*a
;
9730 switch (expr2
->expr_type
)
9733 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9736 if (expr2
->value
.function
.esym
9737 && expr2
->value
.function
.esym
->attr
.elemental
)
9739 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9742 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9747 else if (expr2
->value
.function
.isym
9748 && expr2
->value
.function
.isym
->elemental
)
9750 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9753 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9762 switch (expr2
->value
.op
.op
)
9765 case INTRINSIC_UPLUS
:
9766 case INTRINSIC_UMINUS
:
9767 case INTRINSIC_PARENTHESES
:
9768 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9770 case INTRINSIC_PLUS
:
9771 case INTRINSIC_MINUS
:
9772 case INTRINSIC_TIMES
:
9773 case INTRINSIC_DIVIDE
:
9774 case INTRINSIC_POWER
:
9778 case INTRINSIC_NEQV
:
9785 case INTRINSIC_EQ_OS
:
9786 case INTRINSIC_NE_OS
:
9787 case INTRINSIC_GT_OS
:
9788 case INTRINSIC_GE_OS
:
9789 case INTRINSIC_LT_OS
:
9790 case INTRINSIC_LE_OS
:
9792 e1
= expr2
->value
.op
.op1
;
9793 e2
= expr2
->value
.op
.op2
;
9795 if (e1
->rank
== 0 && e2
->rank
> 0)
9796 return is_runtime_conformable (expr1
, e2
);
9797 else if (e1
->rank
> 0 && e2
->rank
== 0)
9798 return is_runtime_conformable (expr1
, e1
);
9799 else if (e1
->rank
> 0 && e2
->rank
> 0)
9800 return is_runtime_conformable (expr1
, e1
)
9801 && is_runtime_conformable (expr1
, e2
);
9819 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9820 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
,
9823 tree tmp
, fcn
, stdcopy
, to_len
, from_len
, vptr
;
9824 vec
<tree
, va_gc
> *args
= NULL
;
9826 vptr
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9829 /* Generate allocation of the lhs. */
9835 tmp
= gfc_vptr_size_get (vptr
);
9836 class_han
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9837 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9838 gfc_init_block (&alloc
);
9839 gfc_allocate_using_malloc (&alloc
, class_han
, tmp
, NULL_TREE
);
9840 tmp
= fold_build2_loc (input_location
, EQ_EXPR
,
9841 logical_type_node
, class_han
,
9842 build_int_cst (prvoid_type_node
, 0));
9843 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
9845 PRED_FORTRAN_FAIL_ALLOC
),
9846 gfc_finish_block (&alloc
),
9847 build_empty_stmt (input_location
));
9848 gfc_add_expr_to_block (&lse
->pre
, tmp
);
9851 fcn
= gfc_vptr_copy_get (vptr
);
9853 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9854 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9857 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9858 || INDIRECT_REF_P (tmp
)
9859 || (rhs
->ts
.type
== BT_DERIVED
9860 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9861 && !rhs
->ts
.u
.derived
->attr
.pointer
9862 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9863 || (UNLIMITED_POLY (rhs
)
9864 && !CLASS_DATA (rhs
)->attr
.pointer
9865 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9866 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9868 vec_safe_push (args
, tmp
);
9869 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9870 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9871 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9872 || INDIRECT_REF_P (tmp
)
9873 || (lhs
->ts
.type
== BT_DERIVED
9874 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9875 && !lhs
->ts
.u
.derived
->attr
.pointer
9876 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9877 || (UNLIMITED_POLY (lhs
)
9878 && !CLASS_DATA (lhs
)->attr
.pointer
9879 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9880 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9882 vec_safe_push (args
, tmp
);
9884 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9886 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9889 vec_safe_push (args
, from_len
);
9890 vec_safe_push (args
, to_len
);
9891 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9893 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9894 logical_type_node
, from_len
,
9895 build_zero_cst (TREE_TYPE (from_len
)));
9896 return fold_build3_loc (input_location
, COND_EXPR
,
9897 void_type_node
, tmp
,
9905 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9906 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9908 gfc_init_block (&tblock
);
9909 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9910 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9911 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9912 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9913 /* When coming from a ptr_copy lhs and rhs are swapped. */
9914 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9915 fold_convert (TREE_TYPE (rhst
), tmp
));
9916 return gfc_finish_block (&tblock
);
9920 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9921 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9922 init_flag indicates initialization expressions and dealloc that no
9923 deallocate prior assignment is needed (if in doubt, set true).
9924 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9925 routine instead of a pointer assignment. Alias resolution is only done,
9926 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9927 where it is known, that newly allocated memory on the lhs can never be
9928 an alias of the rhs. */
9931 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9932 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9937 gfc_ss
*lss_section
;
9944 bool scalar_to_array
;
9947 bool maybe_workshare
= false, lhs_refs_comp
= false, rhs_refs_comp
= false;
9948 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9949 bool is_poly_assign
;
9951 /* Assignment of the form lhs = rhs. */
9952 gfc_start_block (&block
);
9954 gfc_init_se (&lse
, NULL
);
9955 gfc_init_se (&rse
, NULL
);
9958 lss
= gfc_walk_expr (expr1
);
9959 if (gfc_is_reallocatable_lhs (expr1
)
9960 && !(expr2
->expr_type
== EXPR_FUNCTION
9961 && expr2
->value
.function
.isym
!= NULL
9962 && !(expr2
->value
.function
.isym
->elemental
9963 || expr2
->value
.function
.isym
->conversion
)))
9964 lss
->is_alloc_lhs
= 1;
9968 if ((expr1
->ts
.type
== BT_DERIVED
)
9969 && (gfc_is_class_array_function (expr2
)
9970 || gfc_is_alloc_class_scalar_function (expr2
)))
9971 expr2
->must_finalize
= 1;
9973 /* Checking whether a class assignment is desired is quite complicated and
9974 needed at two locations, so do it once only before the information is
9976 lhs_attr
= gfc_expr_attr (expr1
);
9977 is_poly_assign
= (use_vptr_copy
|| lhs_attr
.pointer
9978 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9979 && (expr1
->ts
.type
== BT_CLASS
9980 || gfc_is_class_array_ref (expr1
, NULL
)
9981 || gfc_is_class_scalar_expr (expr1
)
9982 || gfc_is_class_array_ref (expr2
, NULL
)
9983 || gfc_is_class_scalar_expr (expr2
));
9986 /* Only analyze the expressions for coarray properties, when in coarray-lib
9988 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9990 lhs_caf_attr
= gfc_caf_attr (expr1
, false, &lhs_refs_comp
);
9991 rhs_caf_attr
= gfc_caf_attr (expr2
, false, &rhs_refs_comp
);
9994 if (lss
!= gfc_ss_terminator
)
9996 /* The assignment needs scalarization. */
9999 /* Find a non-scalar SS from the lhs. */
10000 while (lss_section
!= gfc_ss_terminator
10001 && lss_section
->info
->type
!= GFC_SS_SECTION
)
10002 lss_section
= lss_section
->next
;
10004 gcc_assert (lss_section
!= gfc_ss_terminator
);
10006 /* Initialize the scalarizer. */
10007 gfc_init_loopinfo (&loop
);
10009 /* Walk the rhs. */
10010 rss
= gfc_walk_expr (expr2
);
10011 if (rss
== gfc_ss_terminator
)
10012 /* The rhs is scalar. Add a ss for the expression. */
10013 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
10014 /* When doing a class assign, then the handle to the rhs needs to be a
10015 pointer to allow for polymorphism. */
10016 if (is_poly_assign
&& expr2
->rank
== 0 && !UNLIMITED_POLY (expr2
))
10017 rss
->info
->type
= GFC_SS_REFERENCE
;
10019 /* Associate the SS with the loop. */
10020 gfc_add_ss_to_loop (&loop
, lss
);
10021 gfc_add_ss_to_loop (&loop
, rss
);
10023 /* Calculate the bounds of the scalarization. */
10024 gfc_conv_ss_startstride (&loop
);
10025 /* Enable loop reversal. */
10026 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
10027 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
10028 /* Resolve any data dependencies in the statement. */
10030 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
10031 /* Setup the scalarizing loops. */
10032 gfc_conv_loop_setup (&loop
, &expr2
->where
);
10034 /* Setup the gfc_se structures. */
10035 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10036 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10039 gfc_mark_ss_chain_used (rss
, 1);
10040 if (loop
.temp_ss
== NULL
)
10043 gfc_mark_ss_chain_used (lss
, 1);
10047 lse
.ss
= loop
.temp_ss
;
10048 gfc_mark_ss_chain_used (lss
, 3);
10049 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
10052 /* Allow the scalarizer to workshare array assignments. */
10053 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
10054 == OMPWS_WORKSHARE_FLAG
10055 && loop
.temp_ss
== NULL
)
10057 maybe_workshare
= true;
10058 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
10061 /* Start the scalarized loop body. */
10062 gfc_start_scalarized_body (&loop
, &body
);
10065 gfc_init_block (&body
);
10067 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
10069 /* Translate the expression. */
10070 rse
.want_coarray
= flag_coarray
== GFC_FCOARRAY_LIB
&& init_flag
10071 && lhs_caf_attr
.codimension
;
10072 gfc_conv_expr (&rse
, expr2
);
10074 /* Deal with the case of a scalar class function assigned to a derived type. */
10075 if (gfc_is_alloc_class_scalar_function (expr2
)
10076 && expr1
->ts
.type
== BT_DERIVED
)
10078 rse
.expr
= gfc_class_data_get (rse
.expr
);
10079 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
10082 /* Stabilize a string length for temporaries. */
10083 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
10084 && !(VAR_P (rse
.string_length
)
10085 || TREE_CODE (rse
.string_length
) == PARM_DECL
10086 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
10087 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
10088 else if (expr2
->ts
.type
== BT_CHARACTER
)
10089 string_length
= rse
.string_length
;
10091 string_length
= NULL_TREE
;
10095 gfc_conv_tmp_array_ref (&lse
);
10096 if (expr2
->ts
.type
== BT_CHARACTER
)
10097 lse
.string_length
= string_length
;
10101 gfc_conv_expr (&lse
, expr1
);
10102 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
10104 && gfc_expr_attr (expr1
).allocatable
10111 tmp
= INDIRECT_REF_P (lse
.expr
)
10112 ? gfc_build_addr_expr (NULL_TREE
, lse
.expr
) : lse
.expr
;
10114 /* We should only get array references here. */
10115 gcc_assert (TREE_CODE (tmp
) == POINTER_PLUS_EXPR
10116 || TREE_CODE (tmp
) == ARRAY_REF
);
10118 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10119 or the array itself(ARRAY_REF). */
10120 tmp
= TREE_OPERAND (tmp
, 0);
10122 /* Provide the address of the array. */
10123 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
10124 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
10126 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
10127 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
10128 msg
= _("Assignment of scalar to unallocated array");
10129 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
10130 &expr1
->where
, msg
);
10133 /* Deallocate the lhs parameterized components if required. */
10134 if (dealloc
&& expr2
->expr_type
== EXPR_FUNCTION
10135 && !expr1
->symtree
->n
.sym
->attr
.associate_var
)
10137 if (expr1
->ts
.type
== BT_DERIVED
10138 && expr1
->ts
.u
.derived
10139 && expr1
->ts
.u
.derived
->attr
.pdt_type
)
10141 tmp
= gfc_deallocate_pdt_comp (expr1
->ts
.u
.derived
, lse
.expr
,
10143 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10145 else if (expr1
->ts
.type
== BT_CLASS
10146 && CLASS_DATA (expr1
)->ts
.u
.derived
10147 && CLASS_DATA (expr1
)->ts
.u
.derived
->attr
.pdt_type
)
10149 tmp
= gfc_class_data_get (lse
.expr
);
10150 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr1
)->ts
.u
.derived
,
10152 gfc_add_expr_to_block (&lse
.pre
, tmp
);
10157 /* Assignments of scalar derived types with allocatable components
10158 to arrays must be done with a deep copy and the rhs temporary
10159 must have its components deallocated afterwards. */
10160 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
10161 && expr2
->ts
.u
.derived
->attr
.alloc_comp
10162 && !gfc_expr_is_variable (expr2
)
10163 && expr1
->rank
&& !expr2
->rank
);
10164 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
10166 && expr1
->ts
.u
.derived
->attr
.alloc_comp
10167 && gfc_is_alloc_class_scalar_function (expr2
));
10168 if (scalar_to_array
&& dealloc
)
10170 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
10171 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
10174 /* When assigning a character function result to a deferred-length variable,
10175 the function call must happen before the (re)allocation of the lhs -
10176 otherwise the character length of the result is not known.
10177 NOTE: This relies on having the exact dependence of the length type
10178 parameter available to the caller; gfortran saves it in the .mod files.
10179 NOTE ALSO: The concatenation operation generates a temporary pointer,
10180 whose allocation must go to the innermost loop.
10181 NOTE ALSO (2): A character conversion may generate a temporary, too. */
10182 if (flag_realloc_lhs
10183 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
10184 && !(lss
!= gfc_ss_terminator
10185 && ((expr2
->expr_type
== EXPR_OP
10186 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
)
10187 || (expr2
->expr_type
== EXPR_FUNCTION
10188 && expr2
->value
.function
.isym
!= NULL
10189 && expr2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
))))
10190 gfc_add_block_to_block (&block
, &rse
.pre
);
10192 /* Nullify the allocatable components corresponding to those of the lhs
10193 derived type, so that the finalization of the function result does not
10194 affect the lhs of the assignment. Prepend is used to ensure that the
10195 nullification occurs before the call to the finalizer. In the case of
10196 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10197 as part of the deep copy. */
10198 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
10199 && (gfc_is_class_array_function (expr2
)
10200 || gfc_is_alloc_class_scalar_function (expr2
)))
10203 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
10204 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
10205 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
10206 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
10209 if (is_poly_assign
)
10210 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
10211 use_vptr_copy
|| (lhs_attr
.allocatable
10212 && !lhs_attr
.dimension
),
10213 flag_realloc_lhs
&& !lhs_attr
.pointer
);
10214 else if (flag_coarray
== GFC_FCOARRAY_LIB
10215 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
10216 && ((lhs_caf_attr
.allocatable
&& lhs_refs_comp
)
10217 || (rhs_caf_attr
.allocatable
&& rhs_refs_comp
)))
10219 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10220 allocatable component, because those need to be accessed via the
10221 caf-runtime. No need to check for coindexes here, because resolve
10222 has rewritten those already. */
10224 gfc_actual_arglist a1
, a2
;
10225 /* Clear the structures to prevent accessing garbage. */
10226 memset (&code
, '\0', sizeof (gfc_code
));
10227 memset (&a1
, '\0', sizeof (gfc_actual_arglist
));
10228 memset (&a2
, '\0', sizeof (gfc_actual_arglist
));
10233 code
.ext
.actual
= &a1
;
10234 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
10235 tmp
= gfc_conv_intrinsic_subroutine (&code
);
10238 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10239 gfc_expr_is_variable (expr2
)
10241 || expr2
->expr_type
== EXPR_ARRAY
,
10242 !(l_is_temp
|| init_flag
) && dealloc
,
10243 expr1
->symtree
->n
.sym
->attr
.codimension
);
10244 /* Add the pre blocks to the body. */
10245 gfc_add_block_to_block (&body
, &rse
.pre
);
10246 gfc_add_block_to_block (&body
, &lse
.pre
);
10247 gfc_add_expr_to_block (&body
, tmp
);
10248 /* Add the post blocks to the body. */
10249 gfc_add_block_to_block (&body
, &rse
.post
);
10250 gfc_add_block_to_block (&body
, &lse
.post
);
10252 if (lss
== gfc_ss_terminator
)
10254 /* F2003: Add the code for reallocation on assignment. */
10255 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
)
10256 && !is_poly_assign
)
10257 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
10260 /* Use the scalar assignment as is. */
10261 gfc_add_block_to_block (&block
, &body
);
10265 gcc_assert (lse
.ss
== gfc_ss_terminator
10266 && rse
.ss
== gfc_ss_terminator
);
10270 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
10272 /* We need to copy the temporary to the actual lhs. */
10273 gfc_init_se (&lse
, NULL
);
10274 gfc_init_se (&rse
, NULL
);
10275 gfc_copy_loopinfo_to_se (&lse
, &loop
);
10276 gfc_copy_loopinfo_to_se (&rse
, &loop
);
10278 rse
.ss
= loop
.temp_ss
;
10281 gfc_conv_tmp_array_ref (&rse
);
10282 gfc_conv_expr (&lse
, expr1
);
10284 gcc_assert (lse
.ss
== gfc_ss_terminator
10285 && rse
.ss
== gfc_ss_terminator
);
10287 if (expr2
->ts
.type
== BT_CHARACTER
)
10288 rse
.string_length
= string_length
;
10290 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
10292 gfc_add_expr_to_block (&body
, tmp
);
10295 /* F2003: Allocate or reallocate lhs of allocatable array. */
10296 if (flag_realloc_lhs
10297 && gfc_is_reallocatable_lhs (expr1
)
10299 && !is_runtime_conformable (expr1
, expr2
))
10301 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
10302 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
10303 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
10304 if (tmp
!= NULL_TREE
)
10305 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
10308 if (maybe_workshare
)
10309 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
10311 /* Generate the copying loops. */
10312 gfc_trans_scalarizing_loops (&loop
, &body
);
10314 /* Wrap the whole thing up. */
10315 gfc_add_block_to_block (&block
, &loop
.pre
);
10316 gfc_add_block_to_block (&block
, &loop
.post
);
10318 gfc_cleanup_loop (&loop
);
10321 return gfc_finish_block (&block
);
10325 /* Check whether EXPR is a copyable array. */
10328 copyable_array_p (gfc_expr
* expr
)
10330 if (expr
->expr_type
!= EXPR_VARIABLE
)
10333 /* First check it's an array. */
10334 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
10337 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
10340 /* Next check that it's of a simple enough type. */
10341 switch (expr
->ts
.type
)
10353 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
10362 /* Translate an assignment. */
10365 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
10366 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
10370 /* Special case a single function returning an array. */
10371 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
10373 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
10378 /* Special case assigning an array to zero. */
10379 if (copyable_array_p (expr1
)
10380 && is_zero_initializer_p (expr2
))
10382 tmp
= gfc_trans_zero_assign (expr1
);
10387 /* Special case copying one array to another. */
10388 if (copyable_array_p (expr1
)
10389 && copyable_array_p (expr2
)
10390 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
10391 && !gfc_check_dependency (expr1
, expr2
, 0))
10393 tmp
= gfc_trans_array_copy (expr1
, expr2
);
10398 /* Special case initializing an array from a constant array constructor. */
10399 if (copyable_array_p (expr1
)
10400 && expr2
->expr_type
== EXPR_ARRAY
10401 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
10403 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
10408 /* Fallback to the scalarizer to generate explicit loops. */
10409 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
10410 use_vptr_copy
, may_alias
);
10414 gfc_trans_init_assign (gfc_code
* code
)
10416 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false, true);
10420 gfc_trans_assign (gfc_code
* code
)
10422 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);