1 /* Expression translation
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (CONSTANT_CLASS_P (scalar
))
78 tmp
= gfc_create_var (TREE_TYPE (scalar
), "scalar");
79 gfc_add_modify (&se
->pre
, tmp
, scalar
);
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
83 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
84 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
85 gfc_get_dtype (type
));
86 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
91 gfc_add_modify (&se
->post
, scalar
,
92 fold_convert (TREE_TYPE (scalar
),
93 gfc_conv_descriptor_data_get (desc
)));
98 /* Get the coarray token from the ultimate array or component ref.
99 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
102 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se
*outerse
, gfc_expr
*expr
)
104 gfc_symbol
*sym
= expr
->symtree
->n
.sym
;
105 bool is_coarray
= sym
->attr
.codimension
;
106 gfc_expr
*caf_expr
= gfc_copy_expr (expr
);
107 gfc_ref
*ref
= caf_expr
->ref
, *last_caf_ref
= NULL
;
111 if (ref
->type
== REF_COMPONENT
112 && (ref
->u
.c
.component
->attr
.allocatable
113 || ref
->u
.c
.component
->attr
.pointer
)
114 && (is_coarray
|| ref
->u
.c
.component
->attr
.codimension
))
119 if (last_caf_ref
== NULL
)
122 tree comp
= last_caf_ref
->u
.c
.component
->caf_token
, caf
;
124 bool comp_ref
= !last_caf_ref
->u
.c
.component
->attr
.dimension
;
125 if (comp
== NULL_TREE
&& comp_ref
)
127 gfc_init_se (&se
, outerse
);
128 gfc_free_ref_list (last_caf_ref
->next
);
129 last_caf_ref
->next
= NULL
;
130 caf_expr
->rank
= comp_ref
? 0 : last_caf_ref
->u
.c
.component
->as
->rank
;
131 se
.want_pointer
= comp_ref
;
132 gfc_conv_expr (&se
, caf_expr
);
133 gfc_add_block_to_block (&outerse
->pre
, &se
.pre
);
135 if (TREE_CODE (se
.expr
) == COMPONENT_REF
&& comp_ref
)
136 se
.expr
= TREE_OPERAND (se
.expr
, 0);
137 gfc_free_expr (caf_expr
);
140 caf
= fold_build3_loc (input_location
, COMPONENT_REF
,
141 TREE_TYPE (comp
), se
.expr
, comp
, NULL_TREE
);
143 caf
= gfc_conv_descriptor_token (se
.expr
);
144 return gfc_build_addr_expr (NULL_TREE
, caf
);
148 /* This is the seed for an eventual trans-class.c
150 The following parameters should not be used directly since they might
151 in future implementations. Use the corresponding APIs. */
152 #define CLASS_DATA_FIELD 0
153 #define CLASS_VPTR_FIELD 1
154 #define CLASS_LEN_FIELD 2
155 #define VTABLE_HASH_FIELD 0
156 #define VTABLE_SIZE_FIELD 1
157 #define VTABLE_EXTENDS_FIELD 2
158 #define VTABLE_DEF_INIT_FIELD 3
159 #define VTABLE_COPY_FIELD 4
160 #define VTABLE_FINAL_FIELD 5
161 #define VTABLE_DEALLOCATE_FIELD 6
165 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
169 vec
<constructor_elt
, va_gc
> *init
= NULL
;
171 field
= TYPE_FIELDS (TREE_TYPE (decl
));
172 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
173 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
175 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
176 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
178 return build_constructor (TREE_TYPE (decl
), init
);
183 gfc_class_data_get (tree decl
)
186 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
187 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
188 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
190 return fold_build3_loc (input_location
, COMPONENT_REF
,
191 TREE_TYPE (data
), decl
, data
,
197 gfc_class_vptr_get (tree decl
)
200 /* For class arrays decl may be a temporary descriptor handle, the vptr is
201 then available through the saved descriptor. */
202 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
203 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
204 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
205 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
206 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
207 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
209 return fold_build3_loc (input_location
, COMPONENT_REF
,
210 TREE_TYPE (vptr
), decl
, vptr
,
216 gfc_class_len_get (tree decl
)
219 /* For class arrays decl may be a temporary descriptor handle, the len is
220 then available through the saved descriptor. */
221 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
222 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
223 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
224 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
225 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
226 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
228 return fold_build3_loc (input_location
, COMPONENT_REF
,
229 TREE_TYPE (len
), decl
, len
,
234 /* Try to get the _len component of a class. When the class is not unlimited
235 poly, i.e. no _len field exists, then return a zero node. */
238 gfc_class_len_or_zero_get (tree decl
)
241 /* For class arrays decl may be a temporary descriptor handle, the vptr is
242 then available through the saved descriptor. */
243 if (VAR_P (decl
) && DECL_LANG_SPECIFIC (decl
)
244 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
245 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
246 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
247 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
248 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
250 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
251 TREE_TYPE (len
), decl
, len
,
257 /* Get the specified FIELD from the VPTR. */
260 vptr_field_get (tree vptr
, int fieldno
)
263 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
264 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
266 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
267 TREE_TYPE (field
), vptr
, field
,
274 /* Get the field from the class' vptr. */
277 class_vtab_field_get (tree decl
, int fieldno
)
280 vptr
= gfc_class_vptr_get (decl
);
281 return vptr_field_get (vptr
, fieldno
);
285 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
287 #define VTAB_GET_FIELD_GEN(name, field) tree \
288 gfc_class_vtab_## name ##_get (tree cl) \
290 return class_vtab_field_get (cl, field); \
294 gfc_vptr_## name ##_get (tree vptr) \
296 return vptr_field_get (vptr, field); \
299 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
300 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
301 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
302 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
303 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
304 VTAB_GET_FIELD_GEN (deallocate
, VTABLE_DEALLOCATE_FIELD
)
307 /* The size field is returned as an array index type. Therefore treat
308 it and only it specially. */
311 gfc_class_vtab_size_get (tree cl
)
314 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
315 /* Always return size as an array index type. */
316 size
= fold_convert (gfc_array_index_type
, size
);
322 gfc_vptr_size_get (tree vptr
)
325 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
326 /* Always return size as an array index type. */
327 size
= fold_convert (gfc_array_index_type
, size
);
333 #undef CLASS_DATA_FIELD
334 #undef CLASS_VPTR_FIELD
335 #undef CLASS_LEN_FIELD
336 #undef VTABLE_HASH_FIELD
337 #undef VTABLE_SIZE_FIELD
338 #undef VTABLE_EXTENDS_FIELD
339 #undef VTABLE_DEF_INIT_FIELD
340 #undef VTABLE_COPY_FIELD
341 #undef VTABLE_FINAL_FIELD
344 /* Search for the last _class ref in the chain of references of this
345 expression and cut the chain there. Albeit this routine is similiar
346 to class.c::gfc_add_component_ref (), is there a significant
347 difference: gfc_add_component_ref () concentrates on an array ref to
348 be the last ref in the chain. This routine is oblivious to the kind
349 of refs following. */
352 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
355 gfc_ref
*ref
, *class_ref
, *tail
= NULL
, *array_ref
;
357 /* Find the last class reference. */
360 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
362 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
365 if (ref
->type
== REF_COMPONENT
366 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
368 /* Component to the right of a part reference with nonzero rank
369 must not have the ALLOCATABLE attribute. If attempts are
370 made to reference such a component reference, an error results
371 followed by an ICE. */
372 if (array_ref
&& CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
377 if (ref
->next
== NULL
)
381 /* Remove and store all subsequent references after the
385 tail
= class_ref
->next
;
386 class_ref
->next
= NULL
;
388 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
394 base_expr
= gfc_expr_to_initialize (e
);
396 /* Restore the original tail expression. */
399 gfc_free_ref_list (class_ref
->next
);
400 class_ref
->next
= tail
;
402 else if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
404 gfc_free_ref_list (e
->ref
);
411 /* Reset the vptr to the declared type, e.g. after deallocation. */
414 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
421 /* Evaluate the expression and obtain the vptr from it. */
422 gfc_init_se (&se
, NULL
);
424 gfc_conv_expr_descriptor (&se
, e
);
426 gfc_conv_expr (&se
, e
);
427 gfc_add_block_to_block (block
, &se
.pre
);
428 vptr
= gfc_get_vptr_from_expr (se
.expr
);
430 /* If a vptr is not found, we can do nothing more. */
431 if (vptr
== NULL_TREE
)
434 if (UNLIMITED_POLY (e
))
435 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
438 /* Return the vptr to the address of the declared type. */
439 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
440 vtable
= vtab
->backend_decl
;
441 if (vtable
== NULL_TREE
)
442 vtable
= gfc_get_symbol_decl (vtab
);
443 vtable
= gfc_build_addr_expr (NULL
, vtable
);
444 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
445 gfc_add_modify (block
, vptr
, vtable
);
450 /* Reset the len for unlimited polymorphic objects. */
453 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
457 e
= gfc_find_and_cut_at_last_class_ref (expr
);
460 gfc_add_len_component (e
);
461 gfc_init_se (&se_len
, NULL
);
462 gfc_conv_expr (&se_len
, e
);
463 gfc_add_modify (block
, se_len
.expr
,
464 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
469 /* Obtain the vptr of the last class reference in an expression.
470 Return NULL_TREE if no class reference is found. */
473 gfc_get_vptr_from_expr (tree expr
)
478 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
480 type
= TREE_TYPE (tmp
);
483 if (GFC_CLASS_TYPE_P (type
))
484 return gfc_class_vptr_get (tmp
);
485 if (type
!= TYPE_CANONICAL (type
))
486 type
= TYPE_CANONICAL (type
);
490 if (VAR_P (tmp
) || TREE_CODE (tmp
) == PARM_DECL
)
494 if (POINTER_TYPE_P (TREE_TYPE (tmp
)))
495 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
497 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
498 return gfc_class_vptr_get (tmp
);
505 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
508 tree tmp
, tmp2
, type
;
510 gfc_conv_descriptor_data_set (block
, lhs_desc
,
511 gfc_conv_descriptor_data_get (rhs_desc
));
512 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
513 gfc_conv_descriptor_offset_get (rhs_desc
));
515 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
516 gfc_conv_descriptor_dtype (rhs_desc
));
518 /* Assign the dimension as range-ref. */
519 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
520 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
522 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
523 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
524 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
525 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
526 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
527 gfc_add_modify (block
, tmp
, tmp2
);
531 /* Takes a derived type expression and returns the address of a temporary
532 class object of the 'declared' type. If vptr is not NULL, this is
533 used for the temporary class object.
534 optional_alloc_ptr is false when the dummy is neither allocatable
535 nor a pointer; that's only relevant for the optional handling. */
537 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
538 gfc_typespec class_ts
, tree vptr
, bool optional
,
539 bool optional_alloc_ptr
)
542 tree cond_optional
= NULL_TREE
;
548 /* The derived type needs to be converted to a temporary
550 tmp
= gfc_typenode_for_spec (&class_ts
);
551 var
= gfc_create_var (tmp
, "class");
554 ctree
= gfc_class_vptr_get (var
);
556 if (vptr
!= NULL_TREE
)
558 /* Use the dynamic vptr. */
563 /* In this case the vtab corresponds to the derived type and the
564 vptr must point to it. */
565 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
567 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
569 gfc_add_modify (&parmse
->pre
, ctree
,
570 fold_convert (TREE_TYPE (ctree
), tmp
));
572 /* Now set the data field. */
573 ctree
= gfc_class_data_get (var
);
576 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
578 if (parmse
->expr
&& POINTER_TYPE_P (TREE_TYPE (parmse
->expr
)))
580 /* If there is a ready made pointer to a derived type, use it
581 rather than evaluating the expression again. */
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
585 else if (parmse
->ss
&& parmse
->ss
->info
&& parmse
->ss
->info
->useflags
)
587 /* For an array reference in an elemental procedure call we need
588 to retain the ss to provide the scalarized array reference. */
589 gfc_conv_expr_reference (parmse
, e
);
590 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
592 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
594 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
595 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
599 ss
= gfc_walk_expr (e
);
600 if (ss
== gfc_ss_terminator
)
603 gfc_conv_expr_reference (parmse
, e
);
605 /* Scalar to an assumed-rank array. */
606 if (class_ts
.u
.derived
->components
->as
)
609 type
= get_scalar_to_descriptor_type (parmse
->expr
,
611 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
612 gfc_get_dtype (type
));
614 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
615 TREE_TYPE (parmse
->expr
),
616 cond_optional
, parmse
->expr
,
617 fold_convert (TREE_TYPE (parmse
->expr
),
619 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
623 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
625 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
627 fold_convert (TREE_TYPE (tmp
),
629 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
635 gfc_init_block (&block
);
638 gfc_conv_expr_descriptor (parmse
, e
);
640 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
642 gcc_assert (class_ts
.u
.derived
->components
->as
->type
644 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
648 if (gfc_expr_attr (e
).codimension
)
649 parmse
->expr
= fold_build1_loc (input_location
,
653 gfc_add_modify (&block
, ctree
, parmse
->expr
);
658 tmp
= gfc_finish_block (&block
);
660 gfc_init_block (&block
);
661 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
663 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
664 gfc_finish_block (&block
));
665 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
668 gfc_add_block_to_block (&parmse
->pre
, &block
);
672 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
673 && class_ts
.u
.derived
->components
->ts
.u
.derived
674 ->attr
.unlimited_polymorphic
)
676 /* Take care about initializing the _len component correctly. */
677 ctree
= gfc_class_len_get (var
);
678 if (UNLIMITED_POLY (e
))
683 len
= gfc_copy_expr (e
);
684 gfc_add_len_component (len
);
685 gfc_init_se (&se
, NULL
);
686 gfc_conv_expr (&se
, len
);
688 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
689 cond_optional
, se
.expr
,
690 fold_convert (TREE_TYPE (se
.expr
),
696 tmp
= integer_zero_node
;
697 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
700 /* Pass the address of the class object. */
701 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
703 if (optional
&& optional_alloc_ptr
)
704 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
705 TREE_TYPE (parmse
->expr
),
706 cond_optional
, parmse
->expr
,
707 fold_convert (TREE_TYPE (parmse
->expr
),
712 /* Create a new class container, which is required as scalar coarrays
713 have an array descriptor while normal scalars haven't. Optionally,
714 NULL pointer checks are added if the argument is OPTIONAL. */
717 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
718 gfc_typespec class_ts
, bool optional
)
720 tree var
, ctree
, tmp
;
725 gfc_init_block (&block
);
728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
730 if (ref
->type
== REF_COMPONENT
731 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 var
= gfc_typenode_for_spec (&class_ts
);
752 var
= gfc_create_var (var
, "class");
754 ctree
= gfc_class_vptr_get (var
);
755 gfc_add_modify (&block
, ctree
,
756 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
758 ctree
= gfc_class_data_get (var
);
759 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
760 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
762 /* Pass the address of the class object. */
763 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
767 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
770 tmp
= gfc_finish_block (&block
);
772 gfc_init_block (&block
);
773 tmp2
= gfc_class_data_get (var
);
774 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
776 tmp2
= gfc_finish_block (&block
);
778 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
780 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
783 gfc_add_block_to_block (&parmse
->pre
, &block
);
787 /* Takes an intrinsic type expression and returns the address of a temporary
788 class object of the 'declared' type. */
790 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
791 gfc_typespec class_ts
)
799 /* The intrinsic type needs to be converted to a temporary
801 tmp
= gfc_typenode_for_spec (&class_ts
);
802 var
= gfc_create_var (tmp
, "class");
805 ctree
= gfc_class_vptr_get (var
);
807 vtab
= gfc_find_vtab (&e
->ts
);
809 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
810 gfc_add_modify (&parmse
->pre
, ctree
,
811 fold_convert (TREE_TYPE (ctree
), tmp
));
813 /* Now set the data field. */
814 ctree
= gfc_class_data_get (var
);
815 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
817 /* For an array reference in an elemental procedure call we need
818 to retain the ss to provide the scalarized array reference. */
819 gfc_conv_expr_reference (parmse
, e
);
820 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
821 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
825 ss
= gfc_walk_expr (e
);
826 if (ss
== gfc_ss_terminator
)
829 gfc_conv_expr_reference (parmse
, e
);
830 if (class_ts
.u
.derived
->components
->as
831 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
833 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
835 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
836 TREE_TYPE (ctree
), tmp
);
839 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
840 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
845 parmse
->use_offset
= 1;
846 gfc_conv_expr_descriptor (parmse
, e
);
847 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
849 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
850 TREE_TYPE (ctree
), parmse
->expr
);
851 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
854 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
858 gcc_assert (class_ts
.type
== BT_CLASS
);
859 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
860 && class_ts
.u
.derived
->components
->ts
.u
.derived
861 ->attr
.unlimited_polymorphic
)
863 ctree
= gfc_class_len_get (var
);
864 /* When the actual arg is a char array, then set the _len component of the
865 unlimited polymorphic entity to the length of the string. */
866 if (e
->ts
.type
== BT_CHARACTER
)
868 /* Start with parmse->string_length because this seems to be set to a
869 correct value more often. */
870 if (parmse
->string_length
)
871 tmp
= parmse
->string_length
;
872 /* When the string_length is not yet set, then try the backend_decl of
874 else if (e
->ts
.u
.cl
->backend_decl
)
875 tmp
= e
->ts
.u
.cl
->backend_decl
;
876 /* If both of the above approaches fail, then try to generate an
877 expression from the input, which is only feasible currently, when the
878 expression can be evaluated to a constant one. */
881 /* Try to simplify the expression. */
882 gfc_simplify_expr (e
, 0);
883 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
885 /* Amazingly all data is present to compute the length of a
886 constant string, but the expression is not yet there. */
887 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
889 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
890 e
->value
.character
.length
);
891 gfc_conv_const_charlen (e
->ts
.u
.cl
);
892 e
->ts
.u
.cl
->resolved
= 1;
893 tmp
= e
->ts
.u
.cl
->backend_decl
;
897 gfc_error ("Can't compute the length of the char array at %L.",
903 tmp
= integer_zero_node
;
905 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
907 else if (class_ts
.type
== BT_CLASS
908 && class_ts
.u
.derived
->components
909 && class_ts
.u
.derived
->components
->ts
.u
910 .derived
->attr
.unlimited_polymorphic
)
912 ctree
= gfc_class_len_get (var
);
913 gfc_add_modify (&parmse
->pre
, ctree
,
914 fold_convert (TREE_TYPE (ctree
),
917 /* Pass the address of the class object. */
918 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
922 /* Takes a scalarized class array expression and returns the
923 address of a temporary scalar class object of the 'declared'
925 OOP-TODO: This could be improved by adding code that branched on
926 the dynamic type being the same as the declared type. In this case
927 the original class expression can be passed directly.
928 optional_alloc_ptr is false when the dummy is neither allocatable
929 nor a pointer; that's relevant for the optional handling.
930 Set copyback to true if class container's _data and _vtab pointers
931 might get modified. */
934 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
935 bool elemental
, bool copyback
, bool optional
,
936 bool optional_alloc_ptr
)
942 tree cond
= NULL_TREE
;
943 tree slen
= NULL_TREE
;
947 bool full_array
= false;
949 gfc_init_block (&block
);
952 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
954 if (ref
->type
== REF_COMPONENT
955 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
958 if (ref
->next
== NULL
)
962 if ((ref
== NULL
|| class_ref
== ref
)
963 && (!class_ts
.u
.derived
->components
->as
964 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
967 /* Test for FULL_ARRAY. */
968 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
969 && gfc_expr_attr (e
).dimension
)
972 gfc_is_class_array_ref (e
, &full_array
);
974 /* The derived type needs to be converted to a temporary
976 tmp
= gfc_typenode_for_spec (&class_ts
);
977 var
= gfc_create_var (tmp
, "class");
980 ctree
= gfc_class_data_get (var
);
981 if (class_ts
.u
.derived
->components
->as
982 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
986 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
988 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
989 gfc_get_dtype (type
));
991 tmp
= gfc_class_data_get (parmse
->expr
);
992 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
993 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
995 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
998 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
1002 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
1003 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
1004 TREE_TYPE (ctree
), parmse
->expr
);
1005 gfc_add_modify (&block
, ctree
, parmse
->expr
);
1008 /* Return the data component, except in the case of scalarized array
1009 references, where nullification of the cannot occur and so there
1011 if (!elemental
&& full_array
&& copyback
)
1013 if (class_ts
.u
.derived
->components
->as
1014 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
1017 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
1018 gfc_conv_descriptor_data_get (ctree
));
1020 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
1023 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
1027 ctree
= gfc_class_vptr_get (var
);
1029 /* The vptr is the second field of the actual argument.
1030 First we have to find the corresponding class reference. */
1033 if (class_ref
== NULL
1034 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1036 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1038 if (TREE_CODE (tmp
) == FUNCTION_DECL
)
1039 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1041 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
1042 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
1044 slen
= integer_zero_node
;
1048 /* Remove everything after the last class reference, convert the
1049 expression and then recover its tailend once more. */
1051 ref
= class_ref
->next
;
1052 class_ref
->next
= NULL
;
1053 gfc_init_se (&tmpse
, NULL
);
1054 gfc_conv_expr (&tmpse
, e
);
1055 class_ref
->next
= ref
;
1057 slen
= tmpse
.string_length
;
1060 gcc_assert (tmp
!= NULL_TREE
);
1062 /* Dereference if needs be. */
1063 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
1064 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1066 vptr
= gfc_class_vptr_get (tmp
);
1067 gfc_add_modify (&block
, ctree
,
1068 fold_convert (TREE_TYPE (ctree
), vptr
));
1070 /* Return the vptr component, except in the case of scalarized array
1071 references, where the dynamic type cannot change. */
1072 if (!elemental
&& full_array
&& copyback
)
1073 gfc_add_modify (&parmse
->post
, vptr
,
1074 fold_convert (TREE_TYPE (vptr
), ctree
));
1076 /* For unlimited polymorphic objects also set the _len component. */
1077 if (class_ts
.type
== BT_CLASS
1078 && class_ts
.u
.derived
->components
1079 && class_ts
.u
.derived
->components
->ts
.u
1080 .derived
->attr
.unlimited_polymorphic
)
1082 ctree
= gfc_class_len_get (var
);
1083 if (UNLIMITED_POLY (e
))
1084 tmp
= gfc_class_len_get (tmp
);
1085 else if (e
->ts
.type
== BT_CHARACTER
)
1087 gcc_assert (slen
!= NULL_TREE
);
1091 tmp
= integer_zero_node
;
1092 gfc_add_modify (&parmse
->pre
, ctree
,
1093 fold_convert (TREE_TYPE (ctree
), tmp
));
1100 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1101 /* parmse->pre may contain some preparatory instructions for the
1102 temporary array descriptor. Those may only be executed when the
1103 optional argument is set, therefore add parmse->pre's instructions
1104 to block, which is later guarded by an if (optional_arg_given). */
1105 gfc_add_block_to_block (&parmse
->pre
, &block
);
1106 block
.head
= parmse
->pre
.head
;
1107 parmse
->pre
.head
= NULL_TREE
;
1108 tmp
= gfc_finish_block (&block
);
1110 if (optional_alloc_ptr
)
1111 tmp2
= build_empty_stmt (input_location
);
1114 gfc_init_block (&block
);
1116 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1117 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1118 null_pointer_node
));
1119 tmp2
= gfc_finish_block (&block
);
1122 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1124 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1127 gfc_add_block_to_block (&parmse
->pre
, &block
);
1129 /* Pass the address of the class object. */
1130 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1132 if (optional
&& optional_alloc_ptr
)
1133 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1134 TREE_TYPE (parmse
->expr
),
1136 fold_convert (TREE_TYPE (parmse
->expr
),
1137 null_pointer_node
));
1141 /* Given a class array declaration and an index, returns the address
1142 of the referenced element. */
1145 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1147 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1148 gfc_class_data_get (class_decl
);
1149 tree size
= gfc_class_vtab_size_get (class_decl
);
1150 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1151 gfc_array_index_type
,
1154 data
= gfc_conv_descriptor_data_get (data
);
1155 ptr
= fold_convert (pvoid_type_node
, data
);
1156 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1157 return fold_convert (TREE_TYPE (data
), ptr
);
1161 /* Copies one class expression to another, assuming that if either
1162 'to' or 'from' are arrays they are packed. Should 'from' be
1163 NULL_TREE, the initialization expression for 'to' is used, assuming
1164 that the _vptr is set. */
1167 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1177 vec
<tree
, va_gc
> *args
;
1182 bool is_from_desc
= false, is_to_class
= false;
1185 /* To prevent warnings on uninitialized variables. */
1186 from_len
= to_len
= NULL_TREE
;
1188 if (from
!= NULL_TREE
)
1189 fcn
= gfc_class_vtab_copy_get (from
);
1191 fcn
= gfc_class_vtab_copy_get (to
);
1193 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1195 if (from
!= NULL_TREE
)
1197 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1201 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1205 /* Check that from is a class. When the class is part of a coarray,
1206 then from is a common pointer and is to be used as is. */
1207 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1208 ? build_fold_indirect_ref (from
) : from
;
1210 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1211 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1212 ? gfc_class_data_get (from
) : from
;
1213 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1217 from_data
= gfc_class_vtab_def_init_get (to
);
1221 if (from
!= NULL_TREE
&& unlimited
)
1222 from_len
= gfc_class_len_or_zero_get (from
);
1224 from_len
= integer_zero_node
;
1227 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1230 to_data
= gfc_class_data_get (to
);
1232 to_len
= gfc_class_len_get (to
);
1235 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1238 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1240 stmtblock_t loopbody
;
1244 tree orig_nelems
= nelems
; /* Needed for bounds check. */
1246 gfc_init_block (&body
);
1247 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1248 gfc_array_index_type
, nelems
,
1249 gfc_index_one_node
);
1250 nelems
= gfc_evaluate_now (tmp
, &body
);
1251 index
= gfc_create_var (gfc_array_index_type
, "S");
1255 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1256 vec_safe_push (args
, from_ref
);
1259 vec_safe_push (args
, from_data
);
1262 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1265 tmp
= gfc_conv_array_data (to
);
1266 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1267 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1268 gfc_build_array_ref (tmp
, index
, to
));
1270 vec_safe_push (args
, to_ref
);
1272 /* Add bounds check. */
1273 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) > 0 && is_from_desc
)
1276 const char *name
= "<<unknown>>";
1280 name
= (const char *)(DECL_NAME (to
)->identifier
.id
.str
);
1282 from_len
= gfc_conv_descriptor_size (from_data
, 1);
1283 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
1284 boolean_type_node
, from_len
, orig_nelems
);
1285 msg
= xasprintf ("Array bound mismatch for dimension %d "
1286 "of array '%s' (%%ld/%%ld)",
1289 gfc_trans_runtime_check (true, false, tmp
, &body
,
1290 &gfc_current_locus
, msg
,
1291 fold_convert (long_integer_type_node
, orig_nelems
),
1292 fold_convert (long_integer_type_node
, from_len
));
1297 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1299 /* Build the body of the loop. */
1300 gfc_init_block (&loopbody
);
1301 gfc_add_expr_to_block (&loopbody
, tmp
);
1303 /* Build the loop and return. */
1304 gfc_init_loopinfo (&loop
);
1306 loop
.from
[0] = gfc_index_zero_node
;
1307 loop
.loopvar
[0] = index
;
1308 loop
.to
[0] = nelems
;
1309 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1310 gfc_init_block (&ifbody
);
1311 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1312 stdcopy
= gfc_finish_block (&ifbody
);
1313 /* In initialization mode from_len is a constant zero. */
1314 if (unlimited
&& !integer_zerop (from_len
))
1316 vec_safe_push (args
, from_len
);
1317 vec_safe_push (args
, to_len
);
1318 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1319 /* Build the body of the loop. */
1320 gfc_init_block (&loopbody
);
1321 gfc_add_expr_to_block (&loopbody
, tmp
);
1323 /* Build the loop and return. */
1324 gfc_init_loopinfo (&loop
);
1326 loop
.from
[0] = gfc_index_zero_node
;
1327 loop
.loopvar
[0] = index
;
1328 loop
.to
[0] = nelems
;
1329 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1330 gfc_init_block (&ifbody
);
1331 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1332 extcopy
= gfc_finish_block (&ifbody
);
1334 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1335 boolean_type_node
, from_len
,
1337 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1338 void_type_node
, tmp
, extcopy
, stdcopy
);
1339 gfc_add_expr_to_block (&body
, tmp
);
1340 tmp
= gfc_finish_block (&body
);
1344 gfc_add_expr_to_block (&body
, stdcopy
);
1345 tmp
= gfc_finish_block (&body
);
1347 gfc_cleanup_loop (&loop
);
1351 gcc_assert (!is_from_desc
);
1352 vec_safe_push (args
, from_data
);
1353 vec_safe_push (args
, to_data
);
1354 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
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 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1362 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1363 boolean_type_node
, from_len
,
1365 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1366 void_type_node
, tmp
, extcopy
, stdcopy
);
1372 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1373 if (from
== NULL_TREE
)
1376 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1378 from_data
, null_pointer_node
);
1379 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1380 void_type_node
, cond
,
1381 tmp
, build_empty_stmt (input_location
));
1389 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1391 gfc_actual_arglist
*actual
;
1396 actual
= gfc_get_actual_arglist ();
1397 actual
->expr
= gfc_copy_expr (rhs
);
1398 actual
->next
= gfc_get_actual_arglist ();
1399 actual
->next
->expr
= gfc_copy_expr (lhs
);
1400 ppc
= gfc_copy_expr (obj
);
1401 gfc_add_vptr_component (ppc
);
1402 gfc_add_component_ref (ppc
, "_copy");
1403 ppc_code
= gfc_get_code (EXEC_CALL
);
1404 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1405 /* Although '_copy' is set to be elemental in class.c, it is
1406 not staying that way. Find out why, sometime.... */
1407 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1408 ppc_code
->ext
.actual
= actual
;
1409 ppc_code
->expr1
= ppc
;
1410 /* Since '_copy' is elemental, the scalarizer will take care
1411 of arrays in gfc_trans_call. */
1412 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1413 gfc_free_statements (ppc_code
);
1415 if (UNLIMITED_POLY(obj
))
1417 /* Check if rhs is non-NULL. */
1419 gfc_init_se (&src
, NULL
);
1420 gfc_conv_expr (&src
, rhs
);
1421 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1422 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1423 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1424 null_pointer_node
));
1425 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1426 build_empty_stmt (input_location
));
1432 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1433 A MEMCPY is needed to copy the full data from the default initializer
1434 of the dynamic type. */
1437 gfc_trans_class_init_assign (gfc_code
*code
)
1441 gfc_se dst
,src
,memsz
;
1442 gfc_expr
*lhs
, *rhs
, *sz
;
1444 gfc_start_block (&block
);
1446 lhs
= gfc_copy_expr (code
->expr1
);
1447 gfc_add_data_component (lhs
);
1449 rhs
= gfc_copy_expr (code
->expr1
);
1450 gfc_add_vptr_component (rhs
);
1452 /* Make sure that the component backend_decls have been built, which
1453 will not have happened if the derived types concerned have not
1455 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1456 gfc_add_def_init_component (rhs
);
1457 /* The _def_init is always scalar. */
1460 if (code
->expr1
->ts
.type
== BT_CLASS
1461 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1463 gfc_array_spec
*tmparr
= gfc_get_array_spec ();
1464 *tmparr
= *CLASS_DATA (code
->expr1
)->as
;
1465 gfc_add_full_array_ref (lhs
, tmparr
);
1466 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1470 sz
= gfc_copy_expr (code
->expr1
);
1471 gfc_add_vptr_component (sz
);
1472 gfc_add_size_component (sz
);
1474 gfc_init_se (&dst
, NULL
);
1475 gfc_init_se (&src
, NULL
);
1476 gfc_init_se (&memsz
, NULL
);
1477 gfc_conv_expr (&dst
, lhs
);
1478 gfc_conv_expr (&src
, rhs
);
1479 gfc_conv_expr (&memsz
, sz
);
1480 gfc_add_block_to_block (&block
, &src
.pre
);
1481 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1483 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1485 if (UNLIMITED_POLY(code
->expr1
))
1487 /* Check if _def_init is non-NULL. */
1488 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1489 boolean_type_node
, src
.expr
,
1490 fold_convert (TREE_TYPE (src
.expr
),
1491 null_pointer_node
));
1492 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1493 tmp
, build_empty_stmt (input_location
));
1497 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1498 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1500 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1501 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1503 build_empty_stmt (input_location
));
1506 gfc_add_expr_to_block (&block
, tmp
);
1508 return gfc_finish_block (&block
);
1512 /* End of prototype trans-class.c */
1516 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1518 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1519 gfc_warning (OPT_Wrealloc_lhs
,
1520 "Code for reallocating the allocatable array at %L will "
1522 else if (warn_realloc_lhs_all
)
1523 gfc_warning (OPT_Wrealloc_lhs_all
,
1524 "Code for reallocating the allocatable variable at %L "
1525 "will be added", where
);
1529 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1532 /* Copy the scalarization loop variables. */
1535 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1538 dest
->loop
= src
->loop
;
1542 /* Initialize a simple expression holder.
1544 Care must be taken when multiple se are created with the same parent.
1545 The child se must be kept in sync. The easiest way is to delay creation
1546 of a child se until after after the previous se has been translated. */
1549 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1551 memset (se
, 0, sizeof (gfc_se
));
1552 gfc_init_block (&se
->pre
);
1553 gfc_init_block (&se
->post
);
1555 se
->parent
= parent
;
1558 gfc_copy_se_loopvars (se
, parent
);
1562 /* Advances to the next SS in the chain. Use this rather than setting
1563 se->ss = se->ss->next because all the parents needs to be kept in sync.
1567 gfc_advance_se_ss_chain (gfc_se
* se
)
1572 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1575 /* Walk down the parent chain. */
1578 /* Simple consistency check. */
1579 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1580 || p
->parent
->ss
->nested_ss
== p
->ss
);
1582 /* If we were in a nested loop, the next scalarized expression can be
1583 on the parent ss' next pointer. Thus we should not take the next
1584 pointer blindly, but rather go up one nest level as long as next
1585 is the end of chain. */
1587 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1597 /* Ensures the result of the expression as either a temporary variable
1598 or a constant so that it can be used repeatedly. */
1601 gfc_make_safe_expr (gfc_se
* se
)
1605 if (CONSTANT_CLASS_P (se
->expr
))
1608 /* We need a temporary for this result. */
1609 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1610 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1615 /* Return an expression which determines if a dummy parameter is present.
1616 Also used for arguments to procedures with multiple entry points. */
1619 gfc_conv_expr_present (gfc_symbol
* sym
)
1623 gcc_assert (sym
->attr
.dummy
);
1624 decl
= gfc_get_symbol_decl (sym
);
1626 /* Intrinsic scalars with VALUE attribute which are passed by value
1627 use a hidden argument to denote the present status. */
1628 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1629 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1630 && !sym
->attr
.dimension
)
1632 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1635 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1637 strcpy (&name
[1], sym
->name
);
1638 tree_name
= get_identifier (name
);
1640 /* Walk function argument list to find hidden arg. */
1641 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1642 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1643 if (DECL_NAME (cond
) == tree_name
)
1650 if (TREE_CODE (decl
) != PARM_DECL
)
1652 /* Array parameters use a temporary descriptor, we want the real
1654 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1655 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1656 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1659 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1660 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1662 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1663 as actual argument to denote absent dummies. For array descriptors,
1664 we thus also need to check the array descriptor. For BT_CLASS, it
1665 can also occur for scalars and F2003 due to type->class wrapping and
1666 class->class wrapping. Note further that BT_CLASS always uses an
1667 array descriptor for arrays, also for explicit-shape/assumed-size. */
1669 if (!sym
->attr
.allocatable
1670 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1671 || (sym
->ts
.type
== BT_CLASS
1672 && !CLASS_DATA (sym
)->attr
.allocatable
1673 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1674 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1675 || sym
->ts
.type
== BT_CLASS
))
1679 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1680 || sym
->as
->type
== AS_ASSUMED_RANK
1681 || sym
->attr
.codimension
))
1682 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1684 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1685 if (sym
->ts
.type
== BT_CLASS
)
1686 tmp
= gfc_class_data_get (tmp
);
1687 tmp
= gfc_conv_array_data (tmp
);
1689 else if (sym
->ts
.type
== BT_CLASS
)
1690 tmp
= gfc_class_data_get (decl
);
1694 if (tmp
!= NULL_TREE
)
1696 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1697 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1698 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1699 boolean_type_node
, cond
, tmp
);
1707 /* Converts a missing, dummy argument into a null or zero. */
1710 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1715 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1719 /* Create a temporary and convert it to the correct type. */
1720 tmp
= gfc_get_int_type (kind
);
1721 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1724 /* Test for a NULL value. */
1725 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1726 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1727 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1728 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1732 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1734 build_zero_cst (TREE_TYPE (se
->expr
)));
1735 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1739 if (ts
.type
== BT_CHARACTER
)
1741 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1742 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1743 present
, se
->string_length
, tmp
);
1744 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1745 se
->string_length
= tmp
;
1751 /* Get the character length of an expression, looking through gfc_refs
1755 gfc_get_expr_charlen (gfc_expr
*e
)
1760 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1761 && e
->ts
.type
== BT_CHARACTER
);
1763 length
= NULL
; /* To silence compiler warning. */
1765 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1768 gfc_init_se (&tmpse
, NULL
);
1769 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1770 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1774 /* First candidate: if the variable is of type CHARACTER, the
1775 expression's length could be the length of the character
1777 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1778 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1780 /* Look through the reference chain for component references. */
1781 for (r
= e
->ref
; r
; r
= r
->next
)
1786 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1787 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1795 /* We should never got substring references here. These will be
1796 broken down by the scalarizer. */
1802 gcc_assert (length
!= NULL
);
1807 /* Return for an expression the backend decl of the coarray. */
1810 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1816 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1818 /* Not-implemented diagnostic. */
1819 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1820 && UNLIMITED_POLY (expr
->symtree
->n
.sym
)
1821 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1822 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1823 "%L is not supported", &expr
->where
);
1825 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1826 if (ref
->type
== REF_COMPONENT
)
1828 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
1829 && UNLIMITED_POLY (ref
->u
.c
.component
)
1830 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1831 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1832 "component at %L is not supported", &expr
->where
);
1835 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1836 gcc_assert (caf_decl
);
1837 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1839 if (expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
1841 caf_decl
= gfc_class_data_get (caf_decl
);
1842 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1845 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1847 if (ref
->type
== REF_COMPONENT
1848 && strcmp (ref
->u
.c
.component
->name
, "_data") != 0)
1850 caf_decl
= gfc_class_data_get (caf_decl
);
1851 if (CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.codimension
)
1855 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1859 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1862 /* The following code assumes that the coarray is a component reachable via
1863 only scalar components/variables; the Fortran standard guarantees this. */
1865 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1866 if (ref
->type
== REF_COMPONENT
)
1868 gfc_component
*comp
= ref
->u
.c
.component
;
1870 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1871 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1872 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1873 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1874 comp
->backend_decl
, NULL_TREE
);
1875 if (comp
->ts
.type
== BT_CLASS
)
1877 caf_decl
= gfc_class_data_get (caf_decl
);
1878 if (CLASS_DATA (comp
)->attr
.codimension
)
1884 if (comp
->attr
.codimension
)
1890 gcc_assert (found
&& caf_decl
);
1895 /* Obtain the Coarray token - and optionally also the offset. */
1898 gfc_get_caf_token_offset (gfc_se
*se
, tree
*token
, tree
*offset
, tree caf_decl
,
1899 tree se_expr
, gfc_expr
*expr
)
1903 /* Coarray token. */
1904 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1906 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1907 == GFC_ARRAY_ALLOCATABLE
1908 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1909 *token
= gfc_conv_descriptor_token (caf_decl
);
1911 else if (DECL_LANG_SPECIFIC (caf_decl
)
1912 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1913 *token
= GFC_DECL_TOKEN (caf_decl
);
1916 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1917 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1918 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1924 /* Offset between the coarray base address and the address wanted. */
1925 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1926 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1927 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1928 *offset
= build_int_cst (gfc_array_index_type
, 0);
1929 else if (DECL_LANG_SPECIFIC (caf_decl
)
1930 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1931 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1932 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1933 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1935 *offset
= build_int_cst (gfc_array_index_type
, 0);
1937 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1938 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1940 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1941 tmp
= gfc_conv_descriptor_data_get (tmp
);
1943 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1944 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1947 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1951 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1952 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1954 if (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1955 && expr
->symtree
->n
.sym
->attr
.codimension
1956 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
1958 gfc_expr
*base_expr
= gfc_copy_expr (expr
);
1959 gfc_ref
*ref
= base_expr
->ref
;
1962 // Iterate through the refs until the last one.
1966 if (ref
->type
== REF_ARRAY
1967 && ref
->u
.ar
.type
!= AR_FULL
)
1969 const int ranksum
= ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
;
1971 for (i
= 0; i
< ranksum
; ++i
)
1973 ref
->u
.ar
.start
[i
] = NULL
;
1974 ref
->u
.ar
.end
[i
] = NULL
;
1976 ref
->u
.ar
.type
= AR_FULL
;
1978 gfc_init_se (&base_se
, NULL
);
1979 if (gfc_caf_attr (base_expr
).dimension
)
1981 gfc_conv_expr_descriptor (&base_se
, base_expr
);
1982 tmp
= gfc_conv_descriptor_data_get (base_se
.expr
);
1986 gfc_conv_expr (&base_se
, base_expr
);
1990 gfc_free_expr (base_expr
);
1991 gfc_add_block_to_block (&se
->pre
, &base_se
.pre
);
1992 gfc_add_block_to_block (&se
->post
, &base_se
.post
);
1994 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1995 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1998 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
2002 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2003 fold_convert (gfc_array_index_type
, *offset
),
2004 fold_convert (gfc_array_index_type
, tmp
));
2008 /* Convert the coindex of a coarray into an image index; the result is
2009 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2010 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2013 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
2016 tree lbound
, ubound
, extent
, tmp
, img_idx
;
2020 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2021 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
2023 gcc_assert (ref
!= NULL
);
2025 if (ref
->u
.ar
.dimen_type
[ref
->u
.ar
.dimen
] == DIMEN_THIS_IMAGE
)
2027 return build_call_expr_loc (input_location
, gfor_fndecl_caf_this_image
, 1,
2031 img_idx
= integer_zero_node
;
2032 extent
= integer_one_node
;
2033 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2034 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2036 gfc_init_se (&se
, NULL
);
2037 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2038 gfc_add_block_to_block (block
, &se
.pre
);
2039 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2040 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2041 integer_type_node
, se
.expr
,
2042 fold_convert(integer_type_node
, lbound
));
2043 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2045 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2047 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2049 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2050 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2051 tmp
= fold_convert (integer_type_node
, tmp
);
2052 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2053 integer_type_node
, extent
, tmp
);
2057 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2059 gfc_init_se (&se
, NULL
);
2060 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2061 gfc_add_block_to_block (block
, &se
.pre
);
2062 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2063 lbound
= fold_convert (integer_type_node
, lbound
);
2064 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2065 integer_type_node
, se
.expr
, lbound
);
2066 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2068 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2070 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2072 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2073 ubound
= fold_convert (integer_type_node
, ubound
);
2074 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2075 integer_type_node
, ubound
, lbound
);
2076 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2077 tmp
, integer_one_node
);
2078 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2079 integer_type_node
, extent
, tmp
);
2082 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2083 img_idx
, integer_one_node
);
2088 /* For each character array constructor subexpression without a ts.u.cl->length,
2089 replace it by its first element (if there aren't any elements, the length
2090 should already be set to zero). */
2093 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2095 gfc_actual_arglist
* arg
;
2101 switch (e
->expr_type
)
2105 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2106 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2110 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2114 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2115 flatten_array_ctors_without_strlen (arg
->expr
);
2120 /* We've found what we're looking for. */
2121 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2126 gcc_assert (e
->value
.constructor
);
2128 c
= gfc_constructor_first (e
->value
.constructor
);
2132 flatten_array_ctors_without_strlen (new_expr
);
2133 gfc_replace_expr (e
, new_expr
);
2137 /* Otherwise, fall through to handle constructor elements. */
2139 case EXPR_STRUCTURE
:
2140 for (c
= gfc_constructor_first (e
->value
.constructor
);
2141 c
; c
= gfc_constructor_next (c
))
2142 flatten_array_ctors_without_strlen (c
->expr
);
2152 /* Generate code to initialize a string length variable. Returns the
2153 value. For array constructors, cl->length might be NULL and in this case,
2154 the first element of the constructor is needed. expr is the original
2155 expression so we can access it but can be NULL if this is not needed. */
2158 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2162 gfc_init_se (&se
, NULL
);
2164 if (!cl
->length
&& cl
->backend_decl
&& VAR_P (cl
->backend_decl
))
2167 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2168 "flatten" array constructors by taking their first element; all elements
2169 should be the same length or a cl->length should be present. */
2172 gfc_expr
* expr_flat
;
2174 expr_flat
= gfc_copy_expr (expr
);
2175 flatten_array_ctors_without_strlen (expr_flat
);
2176 gfc_resolve_expr (expr_flat
);
2178 gfc_conv_expr (&se
, expr_flat
);
2179 gfc_add_block_to_block (pblock
, &se
.pre
);
2180 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2182 gfc_free_expr (expr_flat
);
2186 /* Convert cl->length. */
2188 gcc_assert (cl
->length
);
2190 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2191 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2192 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2193 gfc_add_block_to_block (pblock
, &se
.pre
);
2195 if (cl
->backend_decl
)
2196 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2198 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2203 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2204 const char *name
, locus
*where
)
2214 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2215 type
= build_pointer_type (type
);
2217 gfc_init_se (&start
, se
);
2218 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2219 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2221 if (integer_onep (start
.expr
))
2222 gfc_conv_string_parameter (se
);
2227 /* Avoid multiple evaluation of substring start. */
2228 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2229 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2231 /* Change the start of the string. */
2232 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2235 tmp
= build_fold_indirect_ref_loc (input_location
,
2237 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2238 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2241 /* Length = end + 1 - start. */
2242 gfc_init_se (&end
, se
);
2243 if (ref
->u
.ss
.end
== NULL
)
2244 end
.expr
= se
->string_length
;
2247 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2248 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2252 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2253 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2255 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2257 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2258 boolean_type_node
, start
.expr
,
2261 /* Check lower bound. */
2262 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2264 build_int_cst (gfc_charlen_type_node
, 1));
2265 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2266 boolean_type_node
, nonempty
, fault
);
2268 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2269 "is less than one", name
);
2271 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2272 "is less than one");
2273 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2274 fold_convert (long_integer_type_node
,
2278 /* Check upper bound. */
2279 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2280 end
.expr
, se
->string_length
);
2281 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2282 boolean_type_node
, nonempty
, fault
);
2284 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2285 "exceeds string length (%%ld)", name
);
2287 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2288 "exceeds string length (%%ld)");
2289 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2290 fold_convert (long_integer_type_node
, end
.expr
),
2291 fold_convert (long_integer_type_node
,
2292 se
->string_length
));
2296 /* Try to calculate the length from the start and end expressions. */
2298 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2302 i_len
= mpz_get_si (length
) + 1;
2306 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2307 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2311 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2312 end
.expr
, start
.expr
);
2313 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2314 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2315 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2316 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2319 se
->string_length
= tmp
;
2323 /* Convert a derived type component reference. */
2326 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2334 c
= ref
->u
.c
.component
;
2336 if (c
->backend_decl
== NULL_TREE
2337 && ref
->u
.c
.sym
!= NULL
)
2338 gfc_get_derived_type (ref
->u
.c
.sym
);
2340 field
= c
->backend_decl
;
2341 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2343 context
= DECL_FIELD_CONTEXT (field
);
2345 /* Components can correspond to fields of different containing
2346 types, as components are created without context, whereas
2347 a concrete use of a component has the type of decl as context.
2348 So, if the type doesn't match, we search the corresponding
2349 FIELD_DECL in the parent type. To not waste too much time
2350 we cache this result in norestrict_decl.
2351 On the other hand, if the context is a UNION or a MAP (a
2352 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2354 if (context
!= TREE_TYPE (decl
)
2355 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2356 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2358 tree f2
= c
->norestrict_decl
;
2359 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2360 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2361 if (TREE_CODE (f2
) == FIELD_DECL
2362 && DECL_NAME (f2
) == DECL_NAME (field
))
2365 c
->norestrict_decl
= f2
;
2369 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2370 && strcmp ("_data", c
->name
) == 0)
2372 /* Found a ref to the _data component. Store the associated ref to
2373 the vptr in se->class_vptr. */
2374 se
->class_vptr
= gfc_class_vptr_get (decl
);
2377 se
->class_vptr
= NULL_TREE
;
2379 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2380 decl
, field
, NULL_TREE
);
2384 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2385 strlen () conditional below. */
2386 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2387 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2389 tmp
= c
->ts
.u
.cl
->backend_decl
;
2390 /* Components must always be constant length. */
2391 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2392 se
->string_length
= tmp
;
2395 if (gfc_deferred_strlen (c
, &field
))
2397 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2399 decl
, field
, NULL_TREE
);
2400 se
->string_length
= tmp
;
2403 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2404 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2405 && c
->ts
.type
!= BT_CHARACTER
)
2406 || c
->attr
.proc_pointer
)
2407 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2412 /* This function deals with component references to components of the
2413 parent type for derived type extensions. */
2415 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2423 c
= ref
->u
.c
.component
;
2425 /* Return if the component is in the parent type. */
2426 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2427 if (strcmp (c
->name
, cmp
->name
) == 0)
2430 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2431 parent
.type
= REF_COMPONENT
;
2433 parent
.u
.c
.sym
= dt
;
2434 parent
.u
.c
.component
= dt
->components
;
2436 if (dt
->backend_decl
== NULL
)
2437 gfc_get_derived_type (dt
);
2439 /* Build the reference and call self. */
2440 gfc_conv_component_ref (se
, &parent
);
2441 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2442 parent
.u
.c
.component
= c
;
2443 conv_parent_component_references (se
, &parent
);
2446 /* Return the contents of a variable. Also handles reference/pointer
2447 variables (all Fortran pointer references are implicit). */
2450 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2455 tree parent_decl
= NULL_TREE
;
2458 bool alternate_entry
;
2461 bool first_time
= true;
2463 sym
= expr
->symtree
->n
.sym
;
2464 is_classarray
= IS_CLASS_ARRAY (sym
);
2468 gfc_ss_info
*ss_info
= ss
->info
;
2470 /* Check that something hasn't gone horribly wrong. */
2471 gcc_assert (ss
!= gfc_ss_terminator
);
2472 gcc_assert (ss_info
->expr
== expr
);
2474 /* A scalarized term. We already know the descriptor. */
2475 se
->expr
= ss_info
->data
.array
.descriptor
;
2476 se
->string_length
= ss_info
->string_length
;
2477 ref
= ss_info
->data
.array
.ref
;
2479 gcc_assert (ref
->type
== REF_ARRAY
2480 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2482 gfc_conv_tmp_array_ref (se
);
2486 tree se_expr
= NULL_TREE
;
2488 se
->expr
= gfc_get_symbol_decl (sym
);
2490 /* Deal with references to a parent results or entries by storing
2491 the current_function_decl and moving to the parent_decl. */
2492 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2493 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2494 && sym
->result
== sym
;
2495 entry_master
= sym
->attr
.result
2496 && sym
->ns
->proc_name
->attr
.entry_master
2497 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2498 if (current_function_decl
)
2499 parent_decl
= DECL_CONTEXT (current_function_decl
);
2501 if ((se
->expr
== parent_decl
&& return_value
)
2502 || (sym
->ns
&& sym
->ns
->proc_name
2504 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2505 && (alternate_entry
|| entry_master
)))
2510 /* Special case for assigning the return value of a function.
2511 Self recursive functions must have an explicit return value. */
2512 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2513 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2515 /* Similarly for alternate entry points. */
2516 else if (alternate_entry
2517 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2520 gfc_entry_list
*el
= NULL
;
2522 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2525 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2530 else if (entry_master
2531 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2533 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2538 /* Procedure actual arguments. */
2539 else if (sym
->attr
.flavor
== FL_PROCEDURE
2540 && se
->expr
!= current_function_decl
)
2542 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2544 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2545 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2551 /* Dereference the expression, where needed. Since characters
2552 are entirely different from other types, they are treated
2554 if (sym
->ts
.type
== BT_CHARACTER
)
2556 /* Dereference character pointer dummy arguments
2558 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2560 || sym
->attr
.function
2561 || sym
->attr
.result
))
2562 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2566 else if (!sym
->attr
.value
)
2568 /* Dereference temporaries for class array dummy arguments. */
2569 if (sym
->attr
.dummy
&& is_classarray
2570 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2572 if (!se
->descriptor_only
)
2573 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2575 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2579 /* Dereference non-character scalar dummy arguments. */
2580 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2581 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2582 && (sym
->ts
.type
!= BT_CLASS
2583 || (!CLASS_DATA (sym
)->attr
.dimension
2584 && !(CLASS_DATA (sym
)->attr
.codimension
2585 && CLASS_DATA (sym
)->attr
.allocatable
))))
2586 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2589 /* Dereference scalar hidden result. */
2590 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2591 && (sym
->attr
.function
|| sym
->attr
.result
)
2592 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2593 && !sym
->attr
.always_explicit
)
2594 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2597 /* Dereference non-character, non-class pointer variables.
2598 These must be dummies, results, or scalars. */
2600 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2601 || gfc_is_associate_pointer (sym
)
2602 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2604 || sym
->attr
.function
2606 || (!sym
->attr
.dimension
2607 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2608 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2610 /* Now treat the class array pointer variables accordingly. */
2611 else if (sym
->ts
.type
== BT_CLASS
2613 && (CLASS_DATA (sym
)->attr
.dimension
2614 || CLASS_DATA (sym
)->attr
.codimension
)
2615 && ((CLASS_DATA (sym
)->as
2616 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2617 || CLASS_DATA (sym
)->attr
.allocatable
2618 || CLASS_DATA (sym
)->attr
.class_pointer
))
2619 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2621 /* And the case where a non-dummy, non-result, non-function,
2622 non-allotable and non-pointer classarray is present. This case was
2623 previously covered by the first if, but with introducing the
2624 condition !is_classarray there, that case has to be covered
2626 else if (sym
->ts
.type
== BT_CLASS
2628 && !sym
->attr
.function
2629 && !sym
->attr
.result
2630 && (CLASS_DATA (sym
)->attr
.dimension
2631 || CLASS_DATA (sym
)->attr
.codimension
)
2633 || !CLASS_DATA (sym
)->attr
.allocatable
)
2634 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2635 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2642 /* For character variables, also get the length. */
2643 if (sym
->ts
.type
== BT_CHARACTER
)
2645 /* If the character length of an entry isn't set, get the length from
2646 the master function instead. */
2647 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2648 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2650 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2651 gcc_assert (se
->string_length
);
2659 /* Return the descriptor if that's what we want and this is an array
2660 section reference. */
2661 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2663 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2664 /* Return the descriptor for array pointers and allocations. */
2665 if (se
->want_pointer
2666 && ref
->next
== NULL
&& (se
->descriptor_only
))
2669 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2670 /* Return a pointer to an element. */
2674 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2675 && se
->descriptor_only
2676 && !CLASS_DATA (sym
)->attr
.allocatable
2677 && !CLASS_DATA (sym
)->attr
.class_pointer
2678 && CLASS_DATA (sym
)->as
2679 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2680 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2681 /* Skip the first ref of a _data component, because for class
2682 arrays that one is already done by introducing a temporary
2683 array descriptor. */
2686 if (ref
->u
.c
.sym
->attr
.extension
)
2687 conv_parent_component_references (se
, ref
);
2689 gfc_conv_component_ref (se
, ref
);
2690 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2691 && se
->want_pointer
&& se
->descriptor_only
)
2697 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2698 expr
->symtree
->name
, &expr
->where
);
2708 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2710 if (se
->want_pointer
)
2712 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2713 gfc_conv_string_parameter (se
);
2715 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2720 /* Unary ops are easy... Or they would be if ! was a valid op. */
2723 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2728 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2729 /* Initialize the operand. */
2730 gfc_init_se (&operand
, se
);
2731 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2732 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2734 type
= gfc_typenode_for_spec (&expr
->ts
);
2736 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2737 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2738 All other unary operators have an equivalent GIMPLE unary operator. */
2739 if (code
== TRUTH_NOT_EXPR
)
2740 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2741 build_int_cst (type
, 0));
2743 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2747 /* Expand power operator to optimal multiplications when a value is raised
2748 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2749 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2750 Programming", 3rd Edition, 1998. */
2752 /* This code is mostly duplicated from expand_powi in the backend.
2753 We establish the "optimal power tree" lookup table with the defined size.
2754 The items in the table are the exponents used to calculate the index
2755 exponents. Any integer n less than the value can get an "addition chain",
2756 with the first node being one. */
2757 #define POWI_TABLE_SIZE 256
2759 /* The table is from builtins.c. */
2760 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2762 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2763 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2764 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2765 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2766 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2767 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2768 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2769 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2770 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2771 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2772 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2773 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2774 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2775 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2776 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2777 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2778 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2779 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2780 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2781 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2782 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2783 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2784 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2785 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2786 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2787 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2788 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2789 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2790 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2791 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2792 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2793 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2796 /* If n is larger than lookup table's max index, we use the "window
2798 #define POWI_WINDOW_SIZE 3
2800 /* Recursive function to expand the power operator. The temporary
2801 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2803 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2810 if (n
< POWI_TABLE_SIZE
)
2815 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2816 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2820 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2821 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2822 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2826 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2830 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2831 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2833 if (n
< POWI_TABLE_SIZE
)
2840 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2841 return 1. Else return 0 and a call to runtime library functions
2842 will have to be built. */
2844 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2849 tree vartmp
[POWI_TABLE_SIZE
];
2851 unsigned HOST_WIDE_INT n
;
2853 wide_int wrhs
= rhs
;
2855 /* If exponent is too large, we won't expand it anyway, so don't bother
2856 with large integer values. */
2857 if (!wi::fits_shwi_p (wrhs
))
2860 m
= wrhs
.to_shwi ();
2861 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2862 of the asymmetric range of the integer type. */
2863 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2865 type
= TREE_TYPE (lhs
);
2866 sgn
= tree_int_cst_sgn (rhs
);
2868 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2869 || optimize_size
) && (m
> 2 || m
< -1))
2875 se
->expr
= gfc_build_const (type
, integer_one_node
);
2879 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2880 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2882 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2883 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2884 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2885 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2888 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2891 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2892 boolean_type_node
, tmp
, cond
);
2893 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2894 tmp
, build_int_cst (type
, 1),
2895 build_int_cst (type
, 0));
2899 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2900 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2901 build_int_cst (type
, -1),
2902 build_int_cst (type
, 0));
2903 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2904 cond
, build_int_cst (type
, 1), tmp
);
2908 memset (vartmp
, 0, sizeof (vartmp
));
2912 tmp
= gfc_build_const (type
, integer_one_node
);
2913 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2917 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2923 /* Power op (**). Constant integer exponent has special handling. */
2926 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2928 tree gfc_int4_type_node
;
2931 int res_ikind_1
, res_ikind_2
;
2936 gfc_init_se (&lse
, se
);
2937 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2938 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2939 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2941 gfc_init_se (&rse
, se
);
2942 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2943 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2945 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2946 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2947 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2950 gfc_int4_type_node
= gfc_get_int_type (4);
2952 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2953 library routine. But in the end, we have to convert the result back
2954 if this case applies -- with res_ikind_K, we keep track whether operand K
2955 falls into this case. */
2959 kind
= expr
->value
.op
.op1
->ts
.kind
;
2960 switch (expr
->value
.op
.op2
->ts
.type
)
2963 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2968 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2969 res_ikind_2
= ikind
;
2991 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2993 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
3020 switch (expr
->value
.op
.op1
->ts
.type
)
3023 if (kind
== 3) /* Case 16 was not handled properly above. */
3025 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
3029 /* Use builtins for real ** int4. */
3035 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3039 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3043 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3047 /* Use the __builtin_powil() only if real(kind=16) is
3048 actually the C long double type. */
3049 if (!gfc_real16_is_float128
)
3050 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3058 /* If we don't have a good builtin for this, go for the
3059 library function. */
3061 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3065 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3074 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3078 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3086 se
->expr
= build_call_expr_loc (input_location
,
3087 fndecl
, 2, lse
.expr
, rse
.expr
);
3089 /* Convert the result back if it is of wrong integer kind. */
3090 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3092 /* We want the maximum of both operand kinds as result. */
3093 if (res_ikind_1
< res_ikind_2
)
3094 res_ikind_1
= res_ikind_2
;
3095 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3100 /* Generate code to allocate a string temporary. */
3103 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3108 if (gfc_can_put_var_on_stack (len
))
3110 /* Create a temporary variable to hold the result. */
3111 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3112 gfc_charlen_type_node
, len
,
3113 build_int_cst (gfc_charlen_type_node
, 1));
3114 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3116 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3117 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3119 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3121 var
= gfc_create_var (tmp
, "str");
3122 var
= gfc_build_addr_expr (type
, var
);
3126 /* Allocate a temporary to hold the result. */
3127 var
= gfc_create_var (type
, "pstr");
3128 gcc_assert (POINTER_TYPE_P (type
));
3129 tmp
= TREE_TYPE (type
);
3130 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3131 tmp
= TREE_TYPE (tmp
);
3132 tmp
= TYPE_SIZE_UNIT (tmp
);
3133 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3134 fold_convert (size_type_node
, len
),
3135 fold_convert (size_type_node
, tmp
));
3136 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3137 gfc_add_modify (&se
->pre
, var
, tmp
);
3139 /* Free the temporary afterwards. */
3140 tmp
= gfc_call_free (var
);
3141 gfc_add_expr_to_block (&se
->post
, tmp
);
3148 /* Handle a string concatenation operation. A temporary will be allocated to
3152 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3155 tree len
, type
, var
, tmp
, fndecl
;
3157 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3158 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3159 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3161 gfc_init_se (&lse
, se
);
3162 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3163 gfc_conv_string_parameter (&lse
);
3164 gfc_init_se (&rse
, se
);
3165 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3166 gfc_conv_string_parameter (&rse
);
3168 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3169 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3171 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3172 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3173 if (len
== NULL_TREE
)
3175 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3176 TREE_TYPE (lse
.string_length
),
3177 lse
.string_length
, rse
.string_length
);
3180 type
= build_pointer_type (type
);
3182 var
= gfc_conv_string_tmp (se
, type
, len
);
3184 /* Do the actual concatenation. */
3185 if (expr
->ts
.kind
== 1)
3186 fndecl
= gfor_fndecl_concat_string
;
3187 else if (expr
->ts
.kind
== 4)
3188 fndecl
= gfor_fndecl_concat_string_char4
;
3192 tmp
= build_call_expr_loc (input_location
,
3193 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3194 rse
.string_length
, rse
.expr
);
3195 gfc_add_expr_to_block (&se
->pre
, tmp
);
3197 /* Add the cleanup for the operands. */
3198 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3199 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3202 se
->string_length
= len
;
3205 /* Translates an op expression. Common (binary) cases are handled by this
3206 function, others are passed on. Recursion is used in either case.
3207 We use the fact that (op1.ts == op2.ts) (except for the power
3209 Operators need no special handling for scalarized expressions as long as
3210 they call gfc_conv_simple_val to get their operands.
3211 Character strings get special handling. */
3214 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3216 enum tree_code code
;
3225 switch (expr
->value
.op
.op
)
3227 case INTRINSIC_PARENTHESES
:
3228 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3229 && flag_protect_parens
)
3231 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3232 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3237 case INTRINSIC_UPLUS
:
3238 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3241 case INTRINSIC_UMINUS
:
3242 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3246 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3249 case INTRINSIC_PLUS
:
3253 case INTRINSIC_MINUS
:
3257 case INTRINSIC_TIMES
:
3261 case INTRINSIC_DIVIDE
:
3262 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3263 an integer, we must round towards zero, so we use a
3265 if (expr
->ts
.type
== BT_INTEGER
)
3266 code
= TRUNC_DIV_EXPR
;
3271 case INTRINSIC_POWER
:
3272 gfc_conv_power_op (se
, expr
);
3275 case INTRINSIC_CONCAT
:
3276 gfc_conv_concat_op (se
, expr
);
3280 code
= TRUTH_ANDIF_EXPR
;
3285 code
= TRUTH_ORIF_EXPR
;
3289 /* EQV and NEQV only work on logicals, but since we represent them
3290 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3292 case INTRINSIC_EQ_OS
:
3300 case INTRINSIC_NE_OS
:
3301 case INTRINSIC_NEQV
:
3308 case INTRINSIC_GT_OS
:
3315 case INTRINSIC_GE_OS
:
3322 case INTRINSIC_LT_OS
:
3329 case INTRINSIC_LE_OS
:
3335 case INTRINSIC_USER
:
3336 case INTRINSIC_ASSIGN
:
3337 /* These should be converted into function calls by the frontend. */
3341 fatal_error (input_location
, "Unknown intrinsic op");
3345 /* The only exception to this is **, which is handled separately anyway. */
3346 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3348 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3352 gfc_init_se (&lse
, se
);
3353 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3354 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3357 gfc_init_se (&rse
, se
);
3358 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3359 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3363 gfc_conv_string_parameter (&lse
);
3364 gfc_conv_string_parameter (&rse
);
3366 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3367 rse
.string_length
, rse
.expr
,
3368 expr
->value
.op
.op1
->ts
.kind
,
3370 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3371 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3374 type
= gfc_typenode_for_spec (&expr
->ts
);
3378 /* The result of logical ops is always boolean_type_node. */
3379 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3380 lse
.expr
, rse
.expr
);
3381 se
->expr
= convert (type
, tmp
);
3384 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3386 /* Add the post blocks. */
3387 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3388 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3391 /* If a string's length is one, we convert it to a single character. */
3394 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3398 || !tree_fits_uhwi_p (len
)
3399 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3402 if (TREE_INT_CST_LOW (len
) == 1)
3404 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3405 return build_fold_indirect_ref_loc (input_location
, str
);
3409 && TREE_CODE (str
) == ADDR_EXPR
3410 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3411 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3412 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3413 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3414 && TREE_INT_CST_LOW (len
) > 1
3415 && TREE_INT_CST_LOW (len
)
3416 == (unsigned HOST_WIDE_INT
)
3417 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3419 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3420 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3421 if (TREE_CODE (ret
) == INTEGER_CST
)
3423 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3424 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3425 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3427 for (i
= 1; i
< length
; i
++)
3440 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3443 if (sym
->backend_decl
)
3445 /* This becomes the nominal_type in
3446 function.c:assign_parm_find_data_types. */
3447 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3448 /* This becomes the passed_type in
3449 function.c:assign_parm_find_data_types. C promotes char to
3450 integer for argument passing. */
3451 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3453 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3458 /* If we have a constant character expression, make it into an
3460 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3465 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3466 (int)(*expr
)->value
.character
.string
[0]);
3467 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3469 /* The expr needs to be compatible with a C int. If the
3470 conversion fails, then the 2 causes an ICE. */
3471 ts
.type
= BT_INTEGER
;
3472 ts
.kind
= gfc_c_int_kind
;
3473 gfc_convert_type (*expr
, &ts
, 2);
3476 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3478 if ((*expr
)->ref
== NULL
)
3480 se
->expr
= gfc_string_to_single_character
3481 (build_int_cst (integer_type_node
, 1),
3482 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3484 ((*expr
)->symtree
->n
.sym
)),
3489 gfc_conv_variable (se
, *expr
);
3490 se
->expr
= gfc_string_to_single_character
3491 (build_int_cst (integer_type_node
, 1),
3492 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3500 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3501 if STR is a string literal, otherwise return -1. */
3504 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3507 && TREE_CODE (str
) == ADDR_EXPR
3508 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3509 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3510 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3511 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3512 && tree_fits_uhwi_p (len
)
3513 && tree_to_uhwi (len
) >= 1
3514 && tree_to_uhwi (len
)
3515 == (unsigned HOST_WIDE_INT
)
3516 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3518 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3519 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3520 if (TREE_CODE (folded
) == INTEGER_CST
)
3522 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3523 int length
= TREE_STRING_LENGTH (string_cst
);
3524 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3526 for (; length
> 0; length
--)
3527 if (ptr
[length
- 1] != ' ')
3536 /* Helper to build a call to memcmp. */
3539 build_memcmp_call (tree s1
, tree s2
, tree n
)
3543 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3544 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3546 s1
= fold_convert (pvoid_type_node
, s1
);
3548 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3549 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3551 s2
= fold_convert (pvoid_type_node
, s2
);
3553 n
= fold_convert (size_type_node
, n
);
3555 tmp
= build_call_expr_loc (input_location
,
3556 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3559 return fold_convert (integer_type_node
, tmp
);
3562 /* Compare two strings. If they are all single characters, the result is the
3563 subtraction of them. Otherwise, we build a library call. */
3566 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3567 enum tree_code code
)
3573 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3574 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3576 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3577 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3579 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3581 /* Deal with single character specially. */
3582 sc1
= fold_convert (integer_type_node
, sc1
);
3583 sc2
= fold_convert (integer_type_node
, sc2
);
3584 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3588 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3590 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3592 /* If one string is a string literal with LEN_TRIM longer
3593 than the length of the second string, the strings
3595 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3596 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3597 return integer_one_node
;
3598 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3599 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3600 return integer_one_node
;
3603 /* We can compare via memcpy if the strings are known to be equal
3604 in length and they are
3606 - kind=4 and the comparison is for (in)equality. */
3608 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3609 && tree_int_cst_equal (len1
, len2
)
3610 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3615 chartype
= gfc_get_char_type (kind
);
3616 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3617 fold_convert (TREE_TYPE(len1
),
3618 TYPE_SIZE_UNIT(chartype
)),
3620 return build_memcmp_call (str1
, str2
, tmp
);
3623 /* Build a call for the comparison. */
3625 fndecl
= gfor_fndecl_compare_string
;
3627 fndecl
= gfor_fndecl_compare_string_char4
;
3631 return build_call_expr_loc (input_location
, fndecl
, 4,
3632 len1
, str1
, len2
, str2
);
3636 /* Return the backend_decl for a procedure pointer component. */
3639 get_proc_ptr_comp (gfc_expr
*e
)
3645 gfc_init_se (&comp_se
, NULL
);
3646 e2
= gfc_copy_expr (e
);
3647 /* We have to restore the expr type later so that gfc_free_expr frees
3648 the exact same thing that was allocated.
3649 TODO: This is ugly. */
3650 old_type
= e2
->expr_type
;
3651 e2
->expr_type
= EXPR_VARIABLE
;
3652 gfc_conv_expr (&comp_se
, e2
);
3653 e2
->expr_type
= old_type
;
3655 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3659 /* Convert a typebound function reference from a class object. */
3661 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3666 if (!VAR_P (base_object
))
3668 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3669 gfc_add_modify (&se
->pre
, var
, base_object
);
3671 se
->expr
= gfc_class_vptr_get (base_object
);
3672 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3674 while (ref
&& ref
->next
)
3676 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3677 if (ref
->u
.c
.sym
->attr
.extension
)
3678 conv_parent_component_references (se
, ref
);
3679 gfc_conv_component_ref (se
, ref
);
3680 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3685 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3689 if (gfc_is_proc_ptr_comp (expr
))
3690 tmp
= get_proc_ptr_comp (expr
);
3691 else if (sym
->attr
.dummy
)
3693 tmp
= gfc_get_symbol_decl (sym
);
3694 if (sym
->attr
.proc_pointer
)
3695 tmp
= build_fold_indirect_ref_loc (input_location
,
3697 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3698 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3702 if (!sym
->backend_decl
)
3703 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3705 TREE_USED (sym
->backend_decl
) = 1;
3707 tmp
= sym
->backend_decl
;
3709 if (sym
->attr
.cray_pointee
)
3711 /* TODO - make the cray pointee a pointer to a procedure,
3712 assign the pointer to it and use it for the call. This
3714 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3715 gfc_get_symbol_decl (sym
->cp_pointer
));
3716 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3719 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3721 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3722 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3729 /* Initialize MAPPING. */
3732 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3734 mapping
->syms
= NULL
;
3735 mapping
->charlens
= NULL
;
3739 /* Free all memory held by MAPPING (but not MAPPING itself). */
3742 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3744 gfc_interface_sym_mapping
*sym
;
3745 gfc_interface_sym_mapping
*nextsym
;
3747 gfc_charlen
*nextcl
;
3749 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3751 nextsym
= sym
->next
;
3752 sym
->new_sym
->n
.sym
->formal
= NULL
;
3753 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3754 gfc_free_expr (sym
->expr
);
3755 free (sym
->new_sym
);
3758 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3761 gfc_free_expr (cl
->length
);
3767 /* Return a copy of gfc_charlen CL. Add the returned structure to
3768 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3770 static gfc_charlen
*
3771 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3774 gfc_charlen
*new_charlen
;
3776 new_charlen
= gfc_get_charlen ();
3777 new_charlen
->next
= mapping
->charlens
;
3778 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3780 mapping
->charlens
= new_charlen
;
3785 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3786 array variable that can be used as the actual argument for dummy
3787 argument SYM. Add any initialization code to BLOCK. PACKED is as
3788 for gfc_get_nodesc_array_type and DATA points to the first element
3789 in the passed array. */
3792 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3793 gfc_packed packed
, tree data
)
3798 type
= gfc_typenode_for_spec (&sym
->ts
);
3799 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3800 !sym
->attr
.target
&& !sym
->attr
.pointer
3801 && !sym
->attr
.proc_pointer
);
3803 var
= gfc_create_var (type
, "ifm");
3804 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3810 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3811 and offset of descriptorless array type TYPE given that it has the same
3812 size as DESC. Add any set-up code to BLOCK. */
3815 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3822 offset
= gfc_index_zero_node
;
3823 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3825 dim
= gfc_rank_cst
[n
];
3826 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3827 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3829 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3830 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3831 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3832 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3834 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3836 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3837 gfc_array_index_type
,
3838 gfc_conv_descriptor_ubound_get (desc
, dim
),
3839 gfc_conv_descriptor_lbound_get (desc
, dim
));
3840 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3841 gfc_array_index_type
,
3842 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3843 tmp
= gfc_evaluate_now (tmp
, block
);
3844 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3846 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3847 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3848 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3849 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3850 gfc_array_index_type
, offset
, tmp
);
3852 offset
= gfc_evaluate_now (offset
, block
);
3853 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3857 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3858 in SE. The caller may still use se->expr and se->string_length after
3859 calling this function. */
3862 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3863 gfc_symbol
* sym
, gfc_se
* se
,
3866 gfc_interface_sym_mapping
*sm
;
3870 gfc_symbol
*new_sym
;
3872 gfc_symtree
*new_symtree
;
3874 /* Create a new symbol to represent the actual argument. */
3875 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3876 new_sym
->ts
= sym
->ts
;
3877 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3878 new_sym
->attr
.referenced
= 1;
3879 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3880 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3881 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3882 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3883 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3884 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3885 new_sym
->attr
.function
= sym
->attr
.function
;
3887 /* Ensure that the interface is available and that
3888 descriptors are passed for array actual arguments. */
3889 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3891 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3892 new_sym
->attr
.always_explicit
3893 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3896 /* Create a fake symtree for it. */
3898 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3899 new_symtree
->n
.sym
= new_sym
;
3900 gcc_assert (new_symtree
== root
);
3902 /* Create a dummy->actual mapping. */
3903 sm
= XCNEW (gfc_interface_sym_mapping
);
3904 sm
->next
= mapping
->syms
;
3906 sm
->new_sym
= new_symtree
;
3907 sm
->expr
= gfc_copy_expr (expr
);
3910 /* Stabilize the argument's value. */
3911 if (!sym
->attr
.function
&& se
)
3912 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3914 if (sym
->ts
.type
== BT_CHARACTER
)
3916 /* Create a copy of the dummy argument's length. */
3917 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3918 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3920 /* If the length is specified as "*", record the length that
3921 the caller is passing. We should use the callee's length
3922 in all other cases. */
3923 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3925 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3926 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3933 /* Use the passed value as-is if the argument is a function. */
3934 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3937 /* If the argument is a pass-by-value scalar, use the value as is. */
3938 else if (!sym
->attr
.dimension
&& sym
->attr
.value
)
3941 /* If the argument is either a string or a pointer to a string,
3942 convert it to a boundless character type. */
3943 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3945 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3946 tmp
= build_pointer_type (tmp
);
3947 if (sym
->attr
.pointer
)
3948 value
= build_fold_indirect_ref_loc (input_location
,
3952 value
= fold_convert (tmp
, value
);
3955 /* If the argument is a scalar, a pointer to an array or an allocatable,
3957 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3958 value
= build_fold_indirect_ref_loc (input_location
,
3961 /* For character(*), use the actual argument's descriptor. */
3962 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3963 value
= build_fold_indirect_ref_loc (input_location
,
3966 /* If the argument is an array descriptor, use it to determine
3967 information about the actual argument's shape. */
3968 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3969 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3971 /* Get the actual argument's descriptor. */
3972 desc
= build_fold_indirect_ref_loc (input_location
,
3975 /* Create the replacement variable. */
3976 tmp
= gfc_conv_descriptor_data_get (desc
);
3977 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3980 /* Use DESC to work out the upper bounds, strides and offset. */
3981 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3984 /* Otherwise we have a packed array. */
3985 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3986 PACKED_FULL
, se
->expr
);
3988 new_sym
->backend_decl
= value
;
3992 /* Called once all dummy argument mappings have been added to MAPPING,
3993 but before the mapping is used to evaluate expressions. Pre-evaluate
3994 the length of each argument, adding any initialization code to PRE and
3995 any finalization code to POST. */
3998 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3999 stmtblock_t
* pre
, stmtblock_t
* post
)
4001 gfc_interface_sym_mapping
*sym
;
4005 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4006 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
4007 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
4009 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
4010 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4011 gfc_init_se (&se
, NULL
);
4012 gfc_conv_expr (&se
, expr
);
4013 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
4014 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
4015 gfc_add_block_to_block (pre
, &se
.pre
);
4016 gfc_add_block_to_block (post
, &se
.post
);
4018 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
4023 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4027 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
4028 gfc_constructor_base base
)
4031 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
4033 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4036 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4037 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4038 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4044 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4048 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4053 for (; ref
; ref
= ref
->next
)
4057 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4059 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4060 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4061 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4069 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4070 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4076 /* Convert intrinsic function calls into result expressions. */
4079 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4087 arg1
= expr
->value
.function
.actual
->expr
;
4088 if (expr
->value
.function
.actual
->next
)
4089 arg2
= expr
->value
.function
.actual
->next
->expr
;
4093 sym
= arg1
->symtree
->n
.sym
;
4095 if (sym
->attr
.dummy
)
4100 switch (expr
->value
.function
.isym
->id
)
4103 /* TODO figure out why this condition is necessary. */
4104 if (sym
->attr
.function
4105 && (arg1
->ts
.u
.cl
->length
== NULL
4106 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4107 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4110 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4114 if (!sym
->as
|| sym
->as
->rank
== 0)
4117 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4119 dup
= mpz_get_si (arg2
->value
.integer
);
4124 dup
= sym
->as
->rank
;
4128 for (; d
< dup
; d
++)
4132 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4134 gfc_free_expr (new_expr
);
4138 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4139 gfc_get_int_expr (gfc_default_integer_kind
,
4141 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4143 new_expr
= gfc_multiply (new_expr
, tmp
);
4149 case GFC_ISYM_LBOUND
:
4150 case GFC_ISYM_UBOUND
:
4151 /* TODO These implementations of lbound and ubound do not limit if
4152 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4154 if (!sym
->as
|| sym
->as
->rank
== 0)
4157 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4158 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4160 /* TODO: If the need arises, this could produce an array of
4164 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4166 if (sym
->as
->lower
[d
])
4167 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4171 if (sym
->as
->upper
[d
])
4172 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4180 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4184 gfc_replace_expr (expr
, new_expr
);
4190 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4191 gfc_interface_mapping
* mapping
)
4193 gfc_formal_arglist
*f
;
4194 gfc_actual_arglist
*actual
;
4196 actual
= expr
->value
.function
.actual
;
4197 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4199 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4204 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4207 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4212 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4214 for (d
= 0; d
< as
->rank
; d
++)
4216 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4217 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4220 expr
->value
.function
.esym
->as
= as
;
4223 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4225 expr
->value
.function
.esym
->ts
.u
.cl
->length
4226 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4228 gfc_apply_interface_mapping_to_expr (mapping
,
4229 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4234 /* EXPR is a copy of an expression that appeared in the interface
4235 associated with MAPPING. Walk it recursively looking for references to
4236 dummy arguments that MAPPING maps to actual arguments. Replace each such
4237 reference with a reference to the associated actual argument. */
4240 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4243 gfc_interface_sym_mapping
*sym
;
4244 gfc_actual_arglist
*actual
;
4249 /* Copying an expression does not copy its length, so do that here. */
4250 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4252 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4253 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4256 /* Apply the mapping to any references. */
4257 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4259 /* ...and to the expression's symbol, if it has one. */
4260 /* TODO Find out why the condition on expr->symtree had to be moved into
4261 the loop rather than being outside it, as originally. */
4262 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4263 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4265 if (sym
->new_sym
->n
.sym
->backend_decl
)
4266 expr
->symtree
= sym
->new_sym
;
4268 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4271 /* ...and to subexpressions in expr->value. */
4272 switch (expr
->expr_type
)
4277 case EXPR_SUBSTRING
:
4281 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4282 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4286 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4287 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4289 if (expr
->value
.function
.esym
== NULL
4290 && expr
->value
.function
.isym
!= NULL
4291 && expr
->value
.function
.actual
->expr
->symtree
4292 && gfc_map_intrinsic_function (expr
, mapping
))
4295 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4296 if (sym
->old
== expr
->value
.function
.esym
)
4298 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4299 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4300 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4305 case EXPR_STRUCTURE
:
4306 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4319 /* Evaluate interface expression EXPR using MAPPING. Store the result
4323 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4324 gfc_se
* se
, gfc_expr
* expr
)
4326 expr
= gfc_copy_expr (expr
);
4327 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4328 gfc_conv_expr (se
, expr
);
4329 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4330 gfc_free_expr (expr
);
4334 /* Returns a reference to a temporary array into which a component of
4335 an actual argument derived type array is copied and then returned
4336 after the function call. */
4338 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4339 sym_intent intent
, bool formal_ptr
)
4347 gfc_array_info
*info
;
4357 gfc_init_se (&lse
, NULL
);
4358 gfc_init_se (&rse
, NULL
);
4360 /* Walk the argument expression. */
4361 rss
= gfc_walk_expr (expr
);
4363 gcc_assert (rss
!= gfc_ss_terminator
);
4365 /* Initialize the scalarizer. */
4366 gfc_init_loopinfo (&loop
);
4367 gfc_add_ss_to_loop (&loop
, rss
);
4369 /* Calculate the bounds of the scalarization. */
4370 gfc_conv_ss_startstride (&loop
);
4372 /* Build an ss for the temporary. */
4373 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4374 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4376 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4377 if (GFC_ARRAY_TYPE_P (base_type
)
4378 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4379 base_type
= gfc_get_element_type (base_type
);
4381 if (expr
->ts
.type
== BT_CLASS
)
4382 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4384 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4385 ? expr
->ts
.u
.cl
->backend_decl
4389 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4391 /* Associate the SS with the loop. */
4392 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4394 /* Setup the scalarizing loops. */
4395 gfc_conv_loop_setup (&loop
, &expr
->where
);
4397 /* Pass the temporary descriptor back to the caller. */
4398 info
= &loop
.temp_ss
->info
->data
.array
;
4399 parmse
->expr
= info
->descriptor
;
4401 /* Setup the gfc_se structures. */
4402 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4403 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4406 lse
.ss
= loop
.temp_ss
;
4407 gfc_mark_ss_chain_used (rss
, 1);
4408 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4410 /* Start the scalarized loop body. */
4411 gfc_start_scalarized_body (&loop
, &body
);
4413 /* Translate the expression. */
4414 gfc_conv_expr (&rse
, expr
);
4416 /* Reset the offset for the function call since the loop
4417 is zero based on the data pointer. Note that the temp
4418 comes first in the loop chain since it is added second. */
4419 if (gfc_is_alloc_class_array_function (expr
))
4421 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4422 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4423 gfc_index_zero_node
);
4426 gfc_conv_tmp_array_ref (&lse
);
4428 if (intent
!= INTENT_OUT
)
4430 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4431 gfc_add_expr_to_block (&body
, tmp
);
4432 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4433 gfc_trans_scalarizing_loops (&loop
, &body
);
4437 /* Make sure that the temporary declaration survives by merging
4438 all the loop declarations into the current context. */
4439 for (n
= 0; n
< loop
.dimen
; n
++)
4441 gfc_merge_block_scope (&body
);
4442 body
= loop
.code
[loop
.order
[n
]];
4444 gfc_merge_block_scope (&body
);
4447 /* Add the post block after the second loop, so that any
4448 freeing of allocated memory is done at the right time. */
4449 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4451 /**********Copy the temporary back again.*********/
4453 gfc_init_se (&lse
, NULL
);
4454 gfc_init_se (&rse
, NULL
);
4456 /* Walk the argument expression. */
4457 lss
= gfc_walk_expr (expr
);
4458 rse
.ss
= loop
.temp_ss
;
4461 /* Initialize the scalarizer. */
4462 gfc_init_loopinfo (&loop2
);
4463 gfc_add_ss_to_loop (&loop2
, lss
);
4465 dimen
= rse
.ss
->dimen
;
4467 /* Skip the write-out loop for this case. */
4468 if (gfc_is_alloc_class_array_function (expr
))
4469 goto class_array_fcn
;
4471 /* Calculate the bounds of the scalarization. */
4472 gfc_conv_ss_startstride (&loop2
);
4474 /* Setup the scalarizing loops. */
4475 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4477 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4478 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4480 gfc_mark_ss_chain_used (lss
, 1);
4481 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4483 /* Declare the variable to hold the temporary offset and start the
4484 scalarized loop body. */
4485 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4486 gfc_start_scalarized_body (&loop2
, &body
);
4488 /* Build the offsets for the temporary from the loop variables. The
4489 temporary array has lbounds of zero and strides of one in all
4490 dimensions, so this is very simple. The offset is only computed
4491 outside the innermost loop, so the overall transfer could be
4492 optimized further. */
4493 info
= &rse
.ss
->info
->data
.array
;
4495 tmp_index
= gfc_index_zero_node
;
4496 for (n
= dimen
- 1; n
> 0; n
--)
4499 tmp
= rse
.loop
->loopvar
[n
];
4500 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4501 tmp
, rse
.loop
->from
[n
]);
4502 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4505 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4506 gfc_array_index_type
,
4507 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4508 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4509 gfc_array_index_type
,
4510 tmp_str
, gfc_index_one_node
);
4512 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4513 gfc_array_index_type
, tmp
, tmp_str
);
4516 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4517 gfc_array_index_type
,
4518 tmp_index
, rse
.loop
->from
[0]);
4519 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4521 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4522 gfc_array_index_type
,
4523 rse
.loop
->loopvar
[0], offset
);
4525 /* Now use the offset for the reference. */
4526 tmp
= build_fold_indirect_ref_loc (input_location
,
4528 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4530 if (expr
->ts
.type
== BT_CHARACTER
)
4531 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4533 gfc_conv_expr (&lse
, expr
);
4535 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4537 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4538 gfc_add_expr_to_block (&body
, tmp
);
4540 /* Generate the copying loops. */
4541 gfc_trans_scalarizing_loops (&loop2
, &body
);
4543 /* Wrap the whole thing up by adding the second loop to the post-block
4544 and following it by the post-block of the first loop. In this way,
4545 if the temporary needs freeing, it is done after use! */
4546 if (intent
!= INTENT_IN
)
4548 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4549 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4554 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4556 gfc_cleanup_loop (&loop
);
4557 gfc_cleanup_loop (&loop2
);
4559 /* Pass the string length to the argument expression. */
4560 if (expr
->ts
.type
== BT_CHARACTER
)
4561 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4563 /* Determine the offset for pointer formal arguments and set the
4567 size
= gfc_index_one_node
;
4568 offset
= gfc_index_zero_node
;
4569 for (n
= 0; n
< dimen
; n
++)
4571 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4573 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4574 gfc_array_index_type
, tmp
,
4575 gfc_index_one_node
);
4576 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4580 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4583 gfc_index_one_node
);
4584 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4585 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4586 gfc_array_index_type
,
4588 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4589 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4590 gfc_array_index_type
,
4591 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4592 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4593 gfc_array_index_type
,
4594 tmp
, gfc_index_one_node
);
4595 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4596 gfc_array_index_type
, size
, tmp
);
4599 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4603 /* We want either the address for the data or the address of the descriptor,
4604 depending on the mode of passing array arguments. */
4606 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4608 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4614 /* Generate the code for argument list functions. */
4617 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4619 /* Pass by value for g77 %VAL(arg), pass the address
4620 indirectly for %LOC, else by reference. Thus %REF
4621 is a "do-nothing" and %LOC is the same as an F95
4623 if (strncmp (name
, "%VAL", 4) == 0)
4624 gfc_conv_expr (se
, expr
);
4625 else if (strncmp (name
, "%LOC", 4) == 0)
4627 gfc_conv_expr_reference (se
, expr
);
4628 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4630 else if (strncmp (name
, "%REF", 4) == 0)
4631 gfc_conv_expr_reference (se
, expr
);
4633 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4637 /* This function tells whether the middle-end representation of the expression
4638 E given as input may point to data otherwise accessible through a variable
4640 It is assumed that the only expressions that may alias are variables,
4641 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4643 This function is used to decide whether freeing an expression's allocatable
4644 components is safe or should be avoided.
4646 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4647 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4648 is necessary because for array constructors, aliasing depends on how
4650 - If E is an array constructor used as argument to an elemental procedure,
4651 the array, which is generated through shallow copy by the scalarizer,
4652 is used directly and can alias the expressions it was copied from.
4653 - If E is an array constructor used as argument to a non-elemental
4654 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4655 the array as in the previous case, but then that array is used
4656 to initialize a new descriptor through deep copy. There is no alias
4657 possible in that case.
4658 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4662 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4666 if (e
->expr_type
== EXPR_VARIABLE
)
4668 else if (e
->expr_type
== EXPR_FUNCTION
)
4670 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4672 if (proc_ifc
->result
!= NULL
4673 && ((proc_ifc
->result
->ts
.type
== BT_CLASS
4674 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4675 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4676 || proc_ifc
->result
->attr
.pointer
))
4681 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4684 for (c
= gfc_constructor_first (e
->value
.constructor
);
4685 c
; c
= gfc_constructor_next (c
))
4687 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4694 /* Generate code for a procedure call. Note can return se->post != NULL.
4695 If se->direct_byref is set then se->expr contains the return parameter.
4696 Return nonzero, if the call has alternate specifiers.
4697 'expr' is only needed for procedure pointer components. */
4700 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4701 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4702 vec
<tree
, va_gc
> *append_args
)
4704 gfc_interface_mapping mapping
;
4705 vec
<tree
, va_gc
> *arglist
;
4706 vec
<tree
, va_gc
> *retargs
;
4710 gfc_array_info
*info
;
4717 vec
<tree
, va_gc
> *stringargs
;
4718 vec
<tree
, va_gc
> *optionalargs
;
4720 gfc_formal_arglist
*formal
;
4721 gfc_actual_arglist
*arg
;
4722 int has_alternate_specifier
= 0;
4723 bool need_interface_mapping
;
4731 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4732 gfc_component
*comp
= NULL
;
4739 optionalargs
= NULL
;
4744 comp
= gfc_get_proc_ptr_comp (expr
);
4746 bool elemental_proc
= (comp
4747 && comp
->ts
.interface
4748 && comp
->ts
.interface
->attr
.elemental
)
4749 || (comp
&& comp
->attr
.elemental
)
4750 || sym
->attr
.elemental
;
4754 if (!elemental_proc
)
4756 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4757 if (se
->ss
->info
->useflags
)
4759 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4760 && sym
->result
->attr
.dimension
)
4761 || (comp
&& comp
->attr
.dimension
)
4762 || gfc_is_alloc_class_array_function (expr
));
4763 gcc_assert (se
->loop
!= NULL
);
4764 /* Access the previously obtained result. */
4765 gfc_conv_tmp_array_ref (se
);
4769 info
= &se
->ss
->info
->data
.array
;
4774 gfc_init_block (&post
);
4775 gfc_init_interface_mapping (&mapping
);
4778 formal
= gfc_sym_get_dummy_args (sym
);
4779 need_interface_mapping
= sym
->attr
.dimension
||
4780 (sym
->ts
.type
== BT_CHARACTER
4781 && sym
->ts
.u
.cl
->length
4782 && sym
->ts
.u
.cl
->length
->expr_type
4787 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4788 need_interface_mapping
= comp
->attr
.dimension
||
4789 (comp
->ts
.type
== BT_CHARACTER
4790 && comp
->ts
.u
.cl
->length
4791 && comp
->ts
.u
.cl
->length
->expr_type
4795 base_object
= NULL_TREE
;
4796 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4797 is the third and fourth argument to such a function call a value
4798 denoting the number of elements to copy (i.e., most of the time the
4799 length of a deferred length string). */
4800 ulim_copy
= (formal
== NULL
)
4801 && UNLIMITED_POLY (sym
)
4802 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4804 /* Evaluate the arguments. */
4805 for (arg
= args
, argc
= 0; arg
!= NULL
;
4806 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4809 fsym
= formal
? formal
->sym
: NULL
;
4810 parm_kind
= MISSING
;
4812 /* If the procedure requires an explicit interface, the actual
4813 argument is passed according to the corresponding formal
4814 argument. If the corresponding formal argument is a POINTER,
4815 ALLOCATABLE or assumed shape, we do not use g77's calling
4816 convention, and pass the address of the array descriptor
4817 instead. Otherwise we use g77's calling convention, in other words
4818 pass the array data pointer without descriptor. */
4819 bool nodesc_arg
= fsym
!= NULL
4820 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4822 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4823 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4825 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4827 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4829 /* Class array expressions are sometimes coming completely unadorned
4830 with either arrayspec or _data component. Correct that here.
4831 OOP-TODO: Move this to the frontend. */
4832 if (e
&& e
->expr_type
== EXPR_VARIABLE
4834 && e
->ts
.type
== BT_CLASS
4835 && (CLASS_DATA (e
)->attr
.codimension
4836 || CLASS_DATA (e
)->attr
.dimension
))
4838 gfc_typespec temp_ts
= e
->ts
;
4839 gfc_add_class_array_ref (e
);
4845 if (se
->ignore_optional
)
4847 /* Some intrinsics have already been resolved to the correct
4851 else if (arg
->label
)
4853 has_alternate_specifier
= 1;
4858 gfc_init_se (&parmse
, NULL
);
4860 /* For scalar arguments with VALUE attribute which are passed by
4861 value, pass "0" and a hidden argument gives the optional
4863 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4864 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4865 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4867 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4869 vec_safe_push (optionalargs
, boolean_false_node
);
4873 /* Pass a NULL pointer for an absent arg. */
4874 parmse
.expr
= null_pointer_node
;
4875 if (arg
->missing_arg_type
== BT_CHARACTER
)
4876 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4881 else if (arg
->expr
->expr_type
== EXPR_NULL
4882 && fsym
&& !fsym
->attr
.pointer
4883 && (fsym
->ts
.type
!= BT_CLASS
4884 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4886 /* Pass a NULL pointer to denote an absent arg. */
4887 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4888 && (fsym
->ts
.type
!= BT_CLASS
4889 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4890 gfc_init_se (&parmse
, NULL
);
4891 parmse
.expr
= null_pointer_node
;
4892 if (arg
->missing_arg_type
== BT_CHARACTER
)
4893 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4895 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4896 && e
->ts
.type
== BT_DERIVED
)
4898 /* The derived type needs to be converted to a temporary
4900 gfc_init_se (&parmse
, se
);
4901 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4903 && e
->expr_type
== EXPR_VARIABLE
4904 && e
->symtree
->n
.sym
->attr
.optional
,
4905 CLASS_DATA (fsym
)->attr
.class_pointer
4906 || CLASS_DATA (fsym
)->attr
.allocatable
);
4908 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4910 /* The intrinsic type needs to be converted to a temporary
4911 CLASS object for the unlimited polymorphic formal. */
4912 gfc_init_se (&parmse
, se
);
4913 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4915 else if (se
->ss
&& se
->ss
->info
->useflags
)
4921 /* An elemental function inside a scalarized loop. */
4922 gfc_init_se (&parmse
, se
);
4923 parm_kind
= ELEMENTAL
;
4925 /* When no fsym is present, ulim_copy is set and this is a third or
4926 fourth argument, use call-by-value instead of by reference to
4927 hand the length properties to the copy routine (i.e., most of the
4928 time this will be a call to a __copy_character_* routine where the
4929 third and fourth arguments are the lengths of a deferred length
4931 if ((fsym
&& fsym
->attr
.value
)
4932 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4933 gfc_conv_expr (&parmse
, e
);
4935 gfc_conv_expr_reference (&parmse
, e
);
4937 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4938 && e
->expr_type
== EXPR_FUNCTION
)
4939 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4942 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4943 && gfc_is_class_container_ref (e
))
4945 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4947 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4948 && e
->symtree
->n
.sym
->attr
.optional
)
4950 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4951 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4952 TREE_TYPE (parmse
.expr
),
4954 fold_convert (TREE_TYPE (parmse
.expr
),
4955 null_pointer_node
));
4959 /* If we are passing an absent array as optional dummy to an
4960 elemental procedure, make sure that we pass NULL when the data
4961 pointer is NULL. We need this extra conditional because of
4962 scalarization which passes arrays elements to the procedure,
4963 ignoring the fact that the array can be absent/unallocated/... */
4964 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4966 tree descriptor_data
;
4968 descriptor_data
= ss
->info
->data
.array
.data
;
4969 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4971 fold_convert (TREE_TYPE (descriptor_data
),
4972 null_pointer_node
));
4974 = fold_build3_loc (input_location
, COND_EXPR
,
4975 TREE_TYPE (parmse
.expr
),
4976 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4977 fold_convert (TREE_TYPE (parmse
.expr
),
4982 /* The scalarizer does not repackage the reference to a class
4983 array - instead it returns a pointer to the data element. */
4984 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4985 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4986 fsym
->attr
.intent
!= INTENT_IN
4987 && (CLASS_DATA (fsym
)->attr
.class_pointer
4988 || CLASS_DATA (fsym
)->attr
.allocatable
),
4990 && e
->expr_type
== EXPR_VARIABLE
4991 && e
->symtree
->n
.sym
->attr
.optional
,
4992 CLASS_DATA (fsym
)->attr
.class_pointer
4993 || CLASS_DATA (fsym
)->attr
.allocatable
);
5000 gfc_init_se (&parmse
, NULL
);
5002 /* Check whether the expression is a scalar or not; we cannot use
5003 e->rank as it can be nonzero for functions arguments. */
5004 argss
= gfc_walk_expr (e
);
5005 scalar
= argss
== gfc_ss_terminator
;
5007 gfc_free_ss_chain (argss
);
5009 /* Special handling for passing scalar polymorphic coarrays;
5010 otherwise one passes "class->_data.data" instead of "&class". */
5011 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
5012 && fsym
&& fsym
->ts
.type
== BT_CLASS
5013 && CLASS_DATA (fsym
)->attr
.codimension
5014 && !CLASS_DATA (fsym
)->attr
.dimension
)
5016 gfc_add_class_array_ref (e
);
5017 parmse
.want_coarray
= 1;
5021 /* A scalar or transformational function. */
5024 if (e
->expr_type
== EXPR_VARIABLE
5025 && e
->symtree
->n
.sym
->attr
.cray_pointee
5026 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
5028 /* The Cray pointer needs to be converted to a pointer to
5029 a type given by the expression. */
5030 gfc_conv_expr (&parmse
, e
);
5031 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
5032 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
5033 parmse
.expr
= convert (type
, tmp
);
5035 else if (fsym
&& fsym
->attr
.value
)
5037 if (fsym
->ts
.type
== BT_CHARACTER
5038 && fsym
->ts
.is_c_interop
5039 && fsym
->ns
->proc_name
!= NULL
5040 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5043 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5044 if (parmse
.expr
== NULL
)
5045 gfc_conv_expr (&parmse
, e
);
5049 gfc_conv_expr (&parmse
, e
);
5050 if (fsym
->attr
.optional
5051 && fsym
->ts
.type
!= BT_CLASS
5052 && fsym
->ts
.type
!= BT_DERIVED
)
5054 if (e
->expr_type
!= EXPR_VARIABLE
5055 || !e
->symtree
->n
.sym
->attr
.optional
5057 vec_safe_push (optionalargs
, boolean_true_node
);
5060 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5061 if (!e
->symtree
->n
.sym
->attr
.value
)
5063 = fold_build3_loc (input_location
, COND_EXPR
,
5064 TREE_TYPE (parmse
.expr
),
5066 fold_convert (TREE_TYPE (parmse
.expr
),
5067 integer_zero_node
));
5069 vec_safe_push (optionalargs
, tmp
);
5074 else if (arg
->name
&& arg
->name
[0] == '%')
5075 /* Argument list functions %VAL, %LOC and %REF are signalled
5076 through arg->name. */
5077 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5078 else if ((e
->expr_type
== EXPR_FUNCTION
)
5079 && ((e
->value
.function
.esym
5080 && e
->value
.function
.esym
->result
->attr
.pointer
)
5081 || (!e
->value
.function
.esym
5082 && e
->symtree
->n
.sym
->attr
.pointer
))
5083 && fsym
&& fsym
->attr
.target
)
5085 gfc_conv_expr (&parmse
, e
);
5086 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5088 else if (e
->expr_type
== EXPR_FUNCTION
5089 && e
->symtree
->n
.sym
->result
5090 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5091 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5093 /* Functions returning procedure pointers. */
5094 gfc_conv_expr (&parmse
, e
);
5095 if (fsym
&& fsym
->attr
.proc_pointer
)
5096 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5100 if (e
->ts
.type
== BT_CLASS
&& fsym
5101 && fsym
->ts
.type
== BT_CLASS
5102 && (!CLASS_DATA (fsym
)->as
5103 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5104 && CLASS_DATA (e
)->attr
.codimension
)
5106 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5107 gcc_assert (!CLASS_DATA (fsym
)->as
);
5108 gfc_add_class_array_ref (e
);
5109 parmse
.want_coarray
= 1;
5110 gfc_conv_expr_reference (&parmse
, e
);
5111 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5113 && e
->expr_type
== EXPR_VARIABLE
);
5115 else if (e
->ts
.type
== BT_CLASS
&& fsym
5116 && fsym
->ts
.type
== BT_CLASS
5117 && !CLASS_DATA (fsym
)->as
5118 && !CLASS_DATA (e
)->as
5119 && strcmp (fsym
->ts
.u
.derived
->name
,
5120 e
->ts
.u
.derived
->name
))
5122 type
= gfc_typenode_for_spec (&fsym
->ts
);
5123 var
= gfc_create_var (type
, fsym
->name
);
5124 gfc_conv_expr (&parmse
, e
);
5125 if (fsym
->attr
.optional
5126 && e
->expr_type
== EXPR_VARIABLE
5127 && e
->symtree
->n
.sym
->attr
.optional
)
5131 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5132 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5133 boolean_type_node
, tmp
,
5134 fold_convert (TREE_TYPE (tmp
),
5135 null_pointer_node
));
5136 gfc_start_block (&block
);
5137 gfc_add_modify (&block
, var
,
5138 fold_build1_loc (input_location
,
5140 type
, parmse
.expr
));
5141 gfc_add_expr_to_block (&parmse
.pre
,
5142 fold_build3_loc (input_location
,
5143 COND_EXPR
, void_type_node
,
5144 cond
, gfc_finish_block (&block
),
5145 build_empty_stmt (input_location
)));
5146 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5147 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5148 TREE_TYPE (parmse
.expr
),
5150 fold_convert (TREE_TYPE (parmse
.expr
),
5151 null_pointer_node
));
5155 gfc_add_modify (&parmse
.pre
, var
,
5156 fold_build1_loc (input_location
,
5158 type
, parmse
.expr
));
5159 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5163 gfc_conv_expr_reference (&parmse
, e
);
5165 /* Catch base objects that are not variables. */
5166 if (e
->ts
.type
== BT_CLASS
5167 && e
->expr_type
!= EXPR_VARIABLE
5168 && expr
&& e
== expr
->base_expr
)
5169 base_object
= build_fold_indirect_ref_loc (input_location
,
5172 /* A class array element needs converting back to be a
5173 class object, if the formal argument is a class object. */
5174 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5175 && e
->ts
.type
== BT_CLASS
5176 && ((CLASS_DATA (fsym
)->as
5177 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5178 || CLASS_DATA (e
)->attr
.dimension
))
5179 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5180 fsym
->attr
.intent
!= INTENT_IN
5181 && (CLASS_DATA (fsym
)->attr
.class_pointer
5182 || CLASS_DATA (fsym
)->attr
.allocatable
),
5184 && e
->expr_type
== EXPR_VARIABLE
5185 && e
->symtree
->n
.sym
->attr
.optional
,
5186 CLASS_DATA (fsym
)->attr
.class_pointer
5187 || CLASS_DATA (fsym
)->attr
.allocatable
);
5189 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5190 allocated on entry, it must be deallocated. */
5191 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5192 && (fsym
->attr
.allocatable
5193 || (fsym
->ts
.type
== BT_CLASS
5194 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5199 gfc_init_block (&block
);
5201 if (e
->ts
.type
== BT_CLASS
)
5202 ptr
= gfc_class_data_get (ptr
);
5204 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5206 gfc_add_expr_to_block (&block
, tmp
);
5207 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5208 void_type_node
, ptr
,
5210 gfc_add_expr_to_block (&block
, tmp
);
5212 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5214 gfc_add_modify (&block
, ptr
,
5215 fold_convert (TREE_TYPE (ptr
),
5216 null_pointer_node
));
5217 gfc_add_expr_to_block (&block
, tmp
);
5219 else if (fsym
->ts
.type
== BT_CLASS
)
5222 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5223 tmp
= gfc_get_symbol_decl (vtab
);
5224 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5225 ptr
= gfc_class_vptr_get (parmse
.expr
);
5226 gfc_add_modify (&block
, ptr
,
5227 fold_convert (TREE_TYPE (ptr
), tmp
));
5228 gfc_add_expr_to_block (&block
, tmp
);
5231 if (fsym
->attr
.optional
5232 && e
->expr_type
== EXPR_VARIABLE
5233 && e
->symtree
->n
.sym
->attr
.optional
)
5235 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5237 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5238 gfc_finish_block (&block
),
5239 build_empty_stmt (input_location
));
5242 tmp
= gfc_finish_block (&block
);
5244 gfc_add_expr_to_block (&se
->pre
, tmp
);
5247 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5248 || fsym
->ts
.type
== BT_ASSUMED
)
5249 && e
->ts
.type
== BT_CLASS
5250 && !CLASS_DATA (e
)->attr
.dimension
5251 && !CLASS_DATA (e
)->attr
.codimension
)
5252 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5254 /* Wrap scalar variable in a descriptor. We need to convert
5255 the address of a pointer back to the pointer itself before,
5256 we can assign it to the data field. */
5258 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5259 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5262 if (TREE_CODE (tmp
) == ADDR_EXPR
5263 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5264 tmp
= TREE_OPERAND (tmp
, 0);
5265 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5267 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5270 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5271 && ((fsym
->attr
.pointer
5272 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5273 || (fsym
->attr
.proc_pointer
5274 && !(e
->expr_type
== EXPR_VARIABLE
5275 && e
->symtree
->n
.sym
->attr
.dummy
))
5276 || (fsym
->attr
.proc_pointer
5277 && e
->expr_type
== EXPR_VARIABLE
5278 && gfc_is_proc_ptr_comp (e
))
5279 || (fsym
->attr
.allocatable
5280 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5282 /* Scalar pointer dummy args require an extra level of
5283 indirection. The null pointer already contains
5284 this level of indirection. */
5285 parm_kind
= SCALAR_POINTER
;
5286 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5290 else if (e
->ts
.type
== BT_CLASS
5291 && fsym
&& fsym
->ts
.type
== BT_CLASS
5292 && (CLASS_DATA (fsym
)->attr
.dimension
5293 || CLASS_DATA (fsym
)->attr
.codimension
))
5295 /* Pass a class array. */
5296 parmse
.use_offset
= 1;
5297 gfc_conv_expr_descriptor (&parmse
, e
);
5299 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5300 allocated on entry, it must be deallocated. */
5301 if (fsym
->attr
.intent
== INTENT_OUT
5302 && CLASS_DATA (fsym
)->attr
.allocatable
)
5307 gfc_init_block (&block
);
5309 ptr
= gfc_class_data_get (ptr
);
5311 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5312 NULL_TREE
, NULL_TREE
,
5315 gfc_add_expr_to_block (&block
, tmp
);
5316 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5317 void_type_node
, ptr
,
5319 gfc_add_expr_to_block (&block
, tmp
);
5320 gfc_reset_vptr (&block
, e
);
5322 if (fsym
->attr
.optional
5323 && e
->expr_type
== EXPR_VARIABLE
5325 || (e
->ref
->type
== REF_ARRAY
5326 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5327 && e
->symtree
->n
.sym
->attr
.optional
)
5329 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5331 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5332 gfc_finish_block (&block
),
5333 build_empty_stmt (input_location
));
5336 tmp
= gfc_finish_block (&block
);
5338 gfc_add_expr_to_block (&se
->pre
, tmp
);
5341 /* The conversion does not repackage the reference to a class
5342 array - _data descriptor. */
5343 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5344 fsym
->attr
.intent
!= INTENT_IN
5345 && (CLASS_DATA (fsym
)->attr
.class_pointer
5346 || CLASS_DATA (fsym
)->attr
.allocatable
),
5348 && e
->expr_type
== EXPR_VARIABLE
5349 && e
->symtree
->n
.sym
->attr
.optional
,
5350 CLASS_DATA (fsym
)->attr
.class_pointer
5351 || CLASS_DATA (fsym
)->attr
.allocatable
);
5355 /* If the argument is a function call that may not create
5356 a temporary for the result, we have to check that we
5357 can do it, i.e. that there is no alias between this
5358 argument and another one. */
5359 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5365 intent
= fsym
->attr
.intent
;
5367 intent
= INTENT_UNKNOWN
;
5369 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5371 parmse
.force_tmp
= 1;
5373 iarg
= e
->value
.function
.actual
->expr
;
5375 /* Temporary needed if aliasing due to host association. */
5376 if (sym
->attr
.contained
5378 && !sym
->attr
.implicit_pure
5379 && !sym
->attr
.use_assoc
5380 && iarg
->expr_type
== EXPR_VARIABLE
5381 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5382 parmse
.force_tmp
= 1;
5384 /* Ditto within module. */
5385 if (sym
->attr
.use_assoc
5387 && !sym
->attr
.implicit_pure
5388 && iarg
->expr_type
== EXPR_VARIABLE
5389 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5390 parmse
.force_tmp
= 1;
5393 if (e
->expr_type
== EXPR_VARIABLE
5394 && is_subref_array (e
))
5395 /* The actual argument is a component reference to an
5396 array of derived types. In this case, the argument
5397 is converted to a temporary, which is passed and then
5398 written back after the procedure call. */
5399 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5400 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5401 fsym
&& fsym
->attr
.pointer
);
5402 else if (gfc_is_class_array_ref (e
, NULL
)
5403 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5404 /* The actual argument is a component reference to an
5405 array of derived types. In this case, the argument
5406 is converted to a temporary, which is passed and then
5407 written back after the procedure call.
5408 OOP-TODO: Insert code so that if the dynamic type is
5409 the same as the declared type, copy-in/copy-out does
5411 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5412 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5413 fsym
&& fsym
->attr
.pointer
);
5415 else if (gfc_is_alloc_class_array_function (e
)
5416 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5417 /* See previous comment. For function actual argument,
5418 the write out is not needed so the intent is set as
5421 e
->must_finalize
= 1;
5422 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5424 fsym
&& fsym
->attr
.pointer
);
5427 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5430 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5431 allocated on entry, it must be deallocated. */
5432 if (fsym
&& fsym
->attr
.allocatable
5433 && fsym
->attr
.intent
== INTENT_OUT
)
5435 tmp
= build_fold_indirect_ref_loc (input_location
,
5437 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5438 if (fsym
->attr
.optional
5439 && e
->expr_type
== EXPR_VARIABLE
5440 && e
->symtree
->n
.sym
->attr
.optional
)
5441 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5443 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5444 tmp
, build_empty_stmt (input_location
));
5445 gfc_add_expr_to_block (&se
->pre
, tmp
);
5450 /* The case with fsym->attr.optional is that of a user subroutine
5451 with an interface indicating an optional argument. When we call
5452 an intrinsic subroutine, however, fsym is NULL, but we might still
5453 have an optional argument, so we proceed to the substitution
5455 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5457 /* If an optional argument is itself an optional dummy argument,
5458 check its presence and substitute a null if absent. This is
5459 only needed when passing an array to an elemental procedure
5460 as then array elements are accessed - or no NULL pointer is
5461 allowed and a "1" or "0" should be passed if not present.
5462 When passing a non-array-descriptor full array to a
5463 non-array-descriptor dummy, no check is needed. For
5464 array-descriptor actual to array-descriptor dummy, see
5465 PR 41911 for why a check has to be inserted.
5466 fsym == NULL is checked as intrinsics required the descriptor
5467 but do not always set fsym. */
5468 if (e
->expr_type
== EXPR_VARIABLE
5469 && e
->symtree
->n
.sym
->attr
.optional
5470 && ((e
->rank
!= 0 && elemental_proc
)
5471 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5475 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5476 || fsym
->as
->type
== AS_ASSUMED_RANK
5477 || fsym
->as
->type
== AS_DEFERRED
))))))
5478 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5479 e
->representation
.length
);
5484 /* Obtain the character length of an assumed character length
5485 length procedure from the typespec. */
5486 if (fsym
->ts
.type
== BT_CHARACTER
5487 && parmse
.string_length
== NULL_TREE
5488 && e
->ts
.type
== BT_PROCEDURE
5489 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5490 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5491 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5493 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5494 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5498 if (fsym
&& need_interface_mapping
&& e
)
5499 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5501 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5502 gfc_add_block_to_block (&post
, &parmse
.post
);
5504 /* Allocated allocatable components of derived types must be
5505 deallocated for non-variable scalars, array arguments to elemental
5506 procedures, and array arguments with descriptor to non-elemental
5507 procedures. As bounds information for descriptorless arrays is no
5508 longer available here, they are dealt with in trans-array.c
5509 (gfc_conv_array_parameter). */
5510 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5511 && e
->ts
.u
.derived
->attr
.alloc_comp
5512 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5513 && !expr_may_alias_variables (e
, elemental_proc
))
5516 /* It is known the e returns a structure type with at least one
5517 allocatable component. When e is a function, ensure that the
5518 function is called once only by using a temporary variable. */
5519 if (!DECL_P (parmse
.expr
))
5520 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5521 parmse
.expr
, &se
->pre
);
5523 if (fsym
&& fsym
->attr
.value
)
5526 tmp
= build_fold_indirect_ref_loc (input_location
,
5529 parm_rank
= e
->rank
;
5537 case (SCALAR_POINTER
):
5538 tmp
= build_fold_indirect_ref_loc (input_location
,
5543 if (e
->expr_type
== EXPR_OP
5544 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5545 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5548 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5549 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5550 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5553 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5555 /* The derived type is passed to gfc_deallocate_alloc_comp.
5556 Therefore, class actuals can handled correctly but derived
5557 types passed to class formals need the _data component. */
5558 tmp
= gfc_class_data_get (tmp
);
5559 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5560 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5563 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5565 gfc_add_expr_to_block (&se
->post
, tmp
);
5568 /* Add argument checking of passing an unallocated/NULL actual to
5569 a nonallocatable/nonpointer dummy. */
5571 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5573 symbol_attribute attr
;
5577 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5578 attr
= gfc_expr_attr (e
);
5580 goto end_pointer_check
;
5582 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5583 allocatable to an optional dummy, cf. 12.5.2.12. */
5584 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5585 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5586 goto end_pointer_check
;
5590 /* If the actual argument is an optional pointer/allocatable and
5591 the formal argument takes an nonpointer optional value,
5592 it is invalid to pass a non-present argument on, even
5593 though there is no technical reason for this in gfortran.
5594 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5595 tree present
, null_ptr
, type
;
5597 if (attr
.allocatable
5598 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5599 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5600 "allocated or not present",
5601 e
->symtree
->n
.sym
->name
);
5602 else if (attr
.pointer
5603 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5604 msg
= xasprintf ("Pointer actual argument '%s' is not "
5605 "associated or not present",
5606 e
->symtree
->n
.sym
->name
);
5607 else if (attr
.proc_pointer
5608 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5609 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5610 "associated or not present",
5611 e
->symtree
->n
.sym
->name
);
5613 goto end_pointer_check
;
5615 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5616 type
= TREE_TYPE (present
);
5617 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5618 boolean_type_node
, present
,
5620 null_pointer_node
));
5621 type
= TREE_TYPE (parmse
.expr
);
5622 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5623 boolean_type_node
, parmse
.expr
,
5625 null_pointer_node
));
5626 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5627 boolean_type_node
, present
, null_ptr
);
5631 if (attr
.allocatable
5632 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5633 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5634 "allocated", e
->symtree
->n
.sym
->name
);
5635 else if (attr
.pointer
5636 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5637 msg
= xasprintf ("Pointer actual argument '%s' is not "
5638 "associated", e
->symtree
->n
.sym
->name
);
5639 else if (attr
.proc_pointer
5640 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5641 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5642 "associated", e
->symtree
->n
.sym
->name
);
5644 goto end_pointer_check
;
5648 /* If the argument is passed by value, we need to strip the
5650 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5651 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5653 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5654 boolean_type_node
, tmp
,
5655 fold_convert (TREE_TYPE (tmp
),
5656 null_pointer_node
));
5659 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5665 /* Deferred length dummies pass the character length by reference
5666 so that the value can be returned. */
5667 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5669 if (INDIRECT_REF_P (parmse
.string_length
))
5670 /* In chains of functions/procedure calls the string_length already
5671 is a pointer to the variable holding the length. Therefore
5672 remove the deref on call. */
5673 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5676 tmp
= parmse
.string_length
;
5677 if (!VAR_P (tmp
) && TREE_CODE (tmp
) != COMPONENT_REF
)
5678 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5679 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5683 /* Character strings are passed as two parameters, a length and a
5684 pointer - except for Bind(c) which only passes the pointer.
5685 An unlimited polymorphic formal argument likewise does not
5687 if (parmse
.string_length
!= NULL_TREE
5688 && !sym
->attr
.is_bind_c
5689 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5690 vec_safe_push (stringargs
, parmse
.string_length
);
5692 /* When calling __copy for character expressions to unlimited
5693 polymorphic entities, the dst argument needs a string length. */
5694 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5695 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5696 && arg
->next
&& arg
->next
->expr
5697 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5698 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5699 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5700 vec_safe_push (stringargs
, parmse
.string_length
);
5702 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5703 pass the token and the offset as additional arguments. */
5704 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5705 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5706 && !fsym
->attr
.allocatable
)
5707 || (fsym
->ts
.type
== BT_CLASS
5708 && CLASS_DATA (fsym
)->attr
.codimension
5709 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5711 /* Token and offset. */
5712 vec_safe_push (stringargs
, null_pointer_node
);
5713 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5714 gcc_assert (fsym
->attr
.optional
);
5716 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5717 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5718 && !fsym
->attr
.allocatable
)
5719 || (fsym
->ts
.type
== BT_CLASS
5720 && CLASS_DATA (fsym
)->attr
.codimension
5721 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5723 tree caf_decl
, caf_type
;
5726 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5727 caf_type
= TREE_TYPE (caf_decl
);
5729 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5730 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5731 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5732 tmp
= gfc_conv_descriptor_token (caf_decl
);
5733 else if (DECL_LANG_SPECIFIC (caf_decl
)
5734 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5735 tmp
= GFC_DECL_TOKEN (caf_decl
);
5738 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5739 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5740 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5743 vec_safe_push (stringargs
, tmp
);
5745 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5746 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5747 offset
= build_int_cst (gfc_array_index_type
, 0);
5748 else if (DECL_LANG_SPECIFIC (caf_decl
)
5749 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5750 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5751 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5752 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5754 offset
= build_int_cst (gfc_array_index_type
, 0);
5756 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5757 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5760 gcc_assert (POINTER_TYPE_P (caf_type
));
5764 tmp2
= fsym
->ts
.type
== BT_CLASS
5765 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5766 if ((fsym
->ts
.type
!= BT_CLASS
5767 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5768 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5769 || (fsym
->ts
.type
== BT_CLASS
5770 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5771 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5773 if (fsym
->ts
.type
== BT_CLASS
)
5774 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5777 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5778 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5780 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5781 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5783 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5784 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5787 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5790 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5791 gfc_array_index_type
,
5792 fold_convert (gfc_array_index_type
, tmp2
),
5793 fold_convert (gfc_array_index_type
, tmp
));
5794 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5795 gfc_array_index_type
, offset
, tmp
);
5797 vec_safe_push (stringargs
, offset
);
5800 vec_safe_push (arglist
, parmse
.expr
);
5802 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5806 else if (sym
->ts
.type
== BT_CLASS
)
5807 ts
= CLASS_DATA (sym
)->ts
;
5811 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5812 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5813 else if (ts
.type
== BT_CHARACTER
)
5815 if (ts
.u
.cl
->length
== NULL
)
5817 /* Assumed character length results are not allowed by 5.1.1.5 of the
5818 standard and are trapped in resolve.c; except in the case of SPREAD
5819 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5820 we take the character length of the first argument for the result.
5821 For dummies, we have to look through the formal argument list for
5822 this function and use the character length found there.*/
5824 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5825 else if (!sym
->attr
.dummy
)
5826 cl
.backend_decl
= (*stringargs
)[0];
5829 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5830 for (; formal
; formal
= formal
->next
)
5831 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5832 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5834 len
= cl
.backend_decl
;
5840 /* Calculate the length of the returned string. */
5841 gfc_init_se (&parmse
, NULL
);
5842 if (need_interface_mapping
)
5843 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5845 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5846 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5847 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5849 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5850 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5851 gfc_charlen_type_node
, tmp
,
5852 build_int_cst (gfc_charlen_type_node
, 0));
5853 cl
.backend_decl
= tmp
;
5856 /* Set up a charlen structure for it. */
5861 len
= cl
.backend_decl
;
5864 byref
= (comp
&& (comp
->attr
.dimension
5865 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5866 || (!comp
&& gfc_return_by_reference (sym
));
5869 if (se
->direct_byref
)
5871 /* Sometimes, too much indirection can be applied; e.g. for
5872 function_result = array_valued_recursive_function. */
5873 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5874 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5875 && GFC_DESCRIPTOR_TYPE_P
5876 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5877 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5880 /* If the lhs of an assignment x = f(..) is allocatable and
5881 f2003 is allowed, we must do the automatic reallocation.
5882 TODO - deal with intrinsics, without using a temporary. */
5883 if (flag_realloc_lhs
5884 && se
->ss
&& se
->ss
->loop_chain
5885 && se
->ss
->loop_chain
->is_alloc_lhs
5886 && !expr
->value
.function
.isym
5887 && sym
->result
->as
!= NULL
)
5889 /* Evaluate the bounds of the result, if known. */
5890 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5893 /* Perform the automatic reallocation. */
5894 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5896 gfc_add_expr_to_block (&se
->pre
, tmp
);
5898 /* Pass the temporary as the first argument. */
5899 result
= info
->descriptor
;
5902 result
= build_fold_indirect_ref_loc (input_location
,
5904 vec_safe_push (retargs
, se
->expr
);
5906 else if (comp
&& comp
->attr
.dimension
)
5908 gcc_assert (se
->loop
&& info
);
5910 /* Set the type of the array. */
5911 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5912 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5914 /* Evaluate the bounds of the result, if known. */
5915 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5917 /* If the lhs of an assignment x = f(..) is allocatable and
5918 f2003 is allowed, we must not generate the function call
5919 here but should just send back the results of the mapping.
5920 This is signalled by the function ss being flagged. */
5921 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5923 gfc_free_interface_mapping (&mapping
);
5924 return has_alternate_specifier
;
5927 /* Create a temporary to store the result. In case the function
5928 returns a pointer, the temporary will be a shallow copy and
5929 mustn't be deallocated. */
5930 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5931 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5932 tmp
, NULL_TREE
, false,
5933 !comp
->attr
.pointer
, callee_alloc
,
5934 &se
->ss
->info
->expr
->where
);
5936 /* Pass the temporary as the first argument. */
5937 result
= info
->descriptor
;
5938 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5939 vec_safe_push (retargs
, tmp
);
5941 else if (!comp
&& sym
->result
->attr
.dimension
)
5943 gcc_assert (se
->loop
&& info
);
5945 /* Set the type of the array. */
5946 tmp
= gfc_typenode_for_spec (&ts
);
5947 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5949 /* Evaluate the bounds of the result, if known. */
5950 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5952 /* If the lhs of an assignment x = f(..) is allocatable and
5953 f2003 is allowed, we must not generate the function call
5954 here but should just send back the results of the mapping.
5955 This is signalled by the function ss being flagged. */
5956 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5958 gfc_free_interface_mapping (&mapping
);
5959 return has_alternate_specifier
;
5962 /* Create a temporary to store the result. In case the function
5963 returns a pointer, the temporary will be a shallow copy and
5964 mustn't be deallocated. */
5965 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5966 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5967 tmp
, NULL_TREE
, false,
5968 !sym
->attr
.pointer
, callee_alloc
,
5969 &se
->ss
->info
->expr
->where
);
5971 /* Pass the temporary as the first argument. */
5972 result
= info
->descriptor
;
5973 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5974 vec_safe_push (retargs
, tmp
);
5976 else if (ts
.type
== BT_CHARACTER
)
5978 /* Pass the string length. */
5979 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5980 type
= build_pointer_type (type
);
5982 /* Return an address to a char[0:len-1]* temporary for
5983 character pointers. */
5984 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5985 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5987 var
= gfc_create_var (type
, "pstr");
5989 if ((!comp
&& sym
->attr
.allocatable
)
5990 || (comp
&& comp
->attr
.allocatable
))
5992 gfc_add_modify (&se
->pre
, var
,
5993 fold_convert (TREE_TYPE (var
),
5994 null_pointer_node
));
5995 tmp
= gfc_call_free (var
);
5996 gfc_add_expr_to_block (&se
->post
, tmp
);
5999 /* Provide an address expression for the function arguments. */
6000 var
= gfc_build_addr_expr (NULL_TREE
, var
);
6003 var
= gfc_conv_string_tmp (se
, type
, len
);
6005 vec_safe_push (retargs
, var
);
6009 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
6011 type
= gfc_get_complex_type (ts
.kind
);
6012 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
6013 vec_safe_push (retargs
, var
);
6016 /* Add the string length to the argument list. */
6017 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
6021 tmp
= gfc_evaluate_now (len
, &se
->pre
);
6022 TREE_STATIC (tmp
) = 1;
6023 gfc_add_modify (&se
->pre
, tmp
,
6024 build_int_cst (TREE_TYPE (tmp
), 0));
6025 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
6026 vec_safe_push (retargs
, tmp
);
6028 else if (ts
.type
== BT_CHARACTER
)
6029 vec_safe_push (retargs
, len
);
6031 gfc_free_interface_mapping (&mapping
);
6033 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6034 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
6035 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
6036 vec_safe_reserve (retargs
, arglen
);
6038 /* Add the return arguments. */
6039 vec_safe_splice (retargs
, arglist
);
6041 /* Add the hidden present status for optional+value to the arguments. */
6042 vec_safe_splice (retargs
, optionalargs
);
6044 /* Add the hidden string length parameters to the arguments. */
6045 vec_safe_splice (retargs
, stringargs
);
6047 /* We may want to append extra arguments here. This is used e.g. for
6048 calls to libgfortran_matmul_??, which need extra information. */
6049 vec_safe_splice (retargs
, append_args
);
6053 /* Generate the actual call. */
6054 if (base_object
== NULL_TREE
)
6055 conv_function_val (se
, sym
, expr
);
6057 conv_base_obj_fcn_val (se
, base_object
, expr
);
6059 /* If there are alternate return labels, function type should be
6060 integer. Can't modify the type in place though, since it can be shared
6061 with other functions. For dummy arguments, the typing is done to
6062 this result, even if it has to be repeated for each call. */
6063 if (has_alternate_specifier
6064 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6066 if (!sym
->attr
.dummy
)
6068 TREE_TYPE (sym
->backend_decl
)
6069 = build_function_type (integer_type_node
,
6070 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6071 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6074 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6077 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6078 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6080 /* Allocatable scalar function results must be freed and nullified
6081 after use. This necessitates the creation of a temporary to
6082 hold the result to prevent duplicate calls. */
6083 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6084 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6086 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6087 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6089 tmp
= gfc_call_free (tmp
);
6090 gfc_add_expr_to_block (&post
, tmp
);
6091 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6094 /* If we have a pointer function, but we don't want a pointer, e.g.
6097 where f is pointer valued, we have to dereference the result. */
6098 if (!se
->want_pointer
&& !byref
6099 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6100 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6101 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6103 /* f2c calling conventions require a scalar default real function to
6104 return a double precision result. Convert this back to default
6105 real. We only care about the cases that can happen in Fortran 77.
6107 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6108 && sym
->ts
.kind
== gfc_default_real_kind
6109 && !sym
->attr
.always_explicit
)
6110 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6112 /* A pure function may still have side-effects - it may modify its
6114 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6116 if (!sym
->attr
.pure
)
6117 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6122 /* Add the function call to the pre chain. There is no expression. */
6123 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6124 se
->expr
= NULL_TREE
;
6126 if (!se
->direct_byref
)
6128 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6130 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6132 /* Check the data pointer hasn't been modified. This would
6133 happen in a function returning a pointer. */
6134 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6135 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6138 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6141 se
->expr
= info
->descriptor
;
6142 /* Bundle in the string length. */
6143 se
->string_length
= len
;
6145 else if (ts
.type
== BT_CHARACTER
)
6147 /* Dereference for character pointer results. */
6148 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6149 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6150 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6154 se
->string_length
= len
;
6158 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6159 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6164 /* Associate the rhs class object's meta-data with the result, when the
6165 result is a temporary. */
6166 if (args
&& args
->expr
&& args
->expr
->ts
.type
== BT_CLASS
6167 && sym
->ts
.type
== BT_CLASS
&& result
!= NULL_TREE
&& DECL_P (result
)
6168 && !GFC_CLASS_TYPE_P (TREE_TYPE (result
)))
6171 gfc_expr
*class_expr
= gfc_find_and_cut_at_last_class_ref (args
->expr
);
6173 gfc_init_se (&parmse
, NULL
);
6174 parmse
.data_not_needed
= 1;
6175 gfc_conv_expr (&parmse
, class_expr
);
6176 if (!DECL_LANG_SPECIFIC (result
))
6177 gfc_allocate_lang_decl (result
);
6178 GFC_DECL_SAVED_DESCRIPTOR (result
) = parmse
.expr
;
6179 gfc_free_expr (class_expr
);
6180 gcc_assert (parmse
.pre
.head
== NULL_TREE
6181 && parmse
.post
.head
== NULL_TREE
);
6184 /* Follow the function call with the argument post block. */
6187 gfc_add_block_to_block (&se
->pre
, &post
);
6189 /* Transformational functions of derived types with allocatable
6190 components must have the result allocatable components copied. */
6191 arg
= expr
->value
.function
.actual
;
6192 if (result
&& arg
&& expr
->rank
6193 && expr
->value
.function
.isym
6194 && expr
->value
.function
.isym
->transformational
6195 && arg
->expr
->ts
.type
== BT_DERIVED
6196 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6199 /* Copy the allocatable components. We have to use a
6200 temporary here to prevent source allocatable components
6201 from being corrupted. */
6202 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6203 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6204 result
, tmp2
, expr
->rank
);
6205 gfc_add_expr_to_block (&se
->pre
, tmp
);
6206 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6208 gfc_add_expr_to_block (&se
->pre
, tmp
);
6210 /* Finally free the temporary's data field. */
6211 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6212 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6213 NULL_TREE
, NULL_TREE
, true,
6215 gfc_add_expr_to_block (&se
->pre
, tmp
);
6220 /* For a function with a class array result, save the result as
6221 a temporary, set the info fields needed by the scalarizer and
6222 call the finalization function of the temporary. Note that the
6223 nullification of allocatable components needed by the result
6224 is done in gfc_trans_assignment_1. */
6225 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6226 && se
->ss
&& se
->ss
->loop
)
6227 || gfc_is_alloc_class_scalar_function (expr
))
6228 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6229 && expr
->must_finalize
)
6234 if (se
->ss
&& se
->ss
->loop
)
6236 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6237 tmp
= gfc_class_data_get (se
->expr
);
6238 info
->descriptor
= tmp
;
6239 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6240 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6241 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6243 tree dim
= gfc_rank_cst
[n
];
6244 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6245 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6250 /* TODO Eliminate the doubling of temporaries. This
6251 one is necessary to ensure no memory leakage. */
6252 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6253 tmp
= gfc_class_data_get (se
->expr
);
6254 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6255 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6258 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6259 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6262 fold_convert (TREE_TYPE (final_fndecl
),
6263 null_pointer_node
));
6264 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6266 tmp
= build_call_expr_loc (input_location
,
6268 gfc_build_addr_expr (NULL
, tmp
),
6269 gfc_class_vtab_size_get (se
->expr
),
6270 boolean_false_node
);
6271 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6272 void_type_node
, is_final
, tmp
,
6273 build_empty_stmt (input_location
));
6275 if (se
->ss
&& se
->ss
->loop
)
6277 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6278 tmp
= gfc_call_free (info
->data
);
6279 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6283 gfc_add_expr_to_block (&se
->post
, tmp
);
6284 tmp
= gfc_class_data_get (se
->expr
);
6285 tmp
= gfc_call_free (tmp
);
6286 gfc_add_expr_to_block (&se
->post
, tmp
);
6288 expr
->must_finalize
= 0;
6291 gfc_add_block_to_block (&se
->post
, &post
);
6294 return has_alternate_specifier
;
6298 /* Fill a character string with spaces. */
6301 fill_with_spaces (tree start
, tree type
, tree size
)
6303 stmtblock_t block
, loop
;
6304 tree i
, el
, exit_label
, cond
, tmp
;
6306 /* For a simple char type, we can call memset(). */
6307 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6308 return build_call_expr_loc (input_location
,
6309 builtin_decl_explicit (BUILT_IN_MEMSET
),
6311 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6312 lang_hooks
.to_target_charset (' ')),
6315 /* Otherwise, we use a loop:
6316 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6320 /* Initialize variables. */
6321 gfc_init_block (&block
);
6322 i
= gfc_create_var (sizetype
, "i");
6323 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6324 el
= gfc_create_var (build_pointer_type (type
), "el");
6325 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6326 exit_label
= gfc_build_label_decl (NULL_TREE
);
6327 TREE_USED (exit_label
) = 1;
6331 gfc_init_block (&loop
);
6333 /* Exit condition. */
6334 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6335 build_zero_cst (sizetype
));
6336 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6337 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6338 build_empty_stmt (input_location
));
6339 gfc_add_expr_to_block (&loop
, tmp
);
6342 gfc_add_modify (&loop
,
6343 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6344 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6346 /* Increment loop variables. */
6347 gfc_add_modify (&loop
, i
,
6348 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6349 TYPE_SIZE_UNIT (type
)));
6350 gfc_add_modify (&loop
, el
,
6351 fold_build_pointer_plus_loc (input_location
,
6352 el
, TYPE_SIZE_UNIT (type
)));
6354 /* Making the loop... actually loop! */
6355 tmp
= gfc_finish_block (&loop
);
6356 tmp
= build1_v (LOOP_EXPR
, tmp
);
6357 gfc_add_expr_to_block (&block
, tmp
);
6359 /* The exit label. */
6360 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6361 gfc_add_expr_to_block (&block
, tmp
);
6364 return gfc_finish_block (&block
);
6368 /* Generate code to copy a string. */
6371 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6372 int dkind
, tree slength
, tree src
, int skind
)
6374 tree tmp
, dlen
, slen
;
6383 stmtblock_t tempblock
;
6385 gcc_assert (dkind
== skind
);
6387 if (slength
!= NULL_TREE
)
6389 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6390 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6394 slen
= build_int_cst (size_type_node
, 1);
6398 if (dlength
!= NULL_TREE
)
6400 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6401 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6405 dlen
= build_int_cst (size_type_node
, 1);
6409 /* Assign directly if the types are compatible. */
6410 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6411 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6413 gfc_add_modify (block
, dsc
, ssc
);
6417 /* Do nothing if the destination length is zero. */
6418 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6419 build_int_cst (size_type_node
, 0));
6421 /* The following code was previously in _gfortran_copy_string:
6423 // The two strings may overlap so we use memmove.
6425 copy_string (GFC_INTEGER_4 destlen, char * dest,
6426 GFC_INTEGER_4 srclen, const char * src)
6428 if (srclen >= destlen)
6430 // This will truncate if too long.
6431 memmove (dest, src, destlen);
6435 memmove (dest, src, srclen);
6437 memset (&dest[srclen], ' ', destlen - srclen);
6441 We're now doing it here for better optimization, but the logic
6444 /* For non-default character kinds, we have to multiply the string
6445 length by the base type size. */
6446 chartype
= gfc_get_char_type (dkind
);
6447 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6448 fold_convert (size_type_node
, slen
),
6449 fold_convert (size_type_node
,
6450 TYPE_SIZE_UNIT (chartype
)));
6451 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6452 fold_convert (size_type_node
, dlen
),
6453 fold_convert (size_type_node
,
6454 TYPE_SIZE_UNIT (chartype
)));
6456 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6457 dest
= fold_convert (pvoid_type_node
, dest
);
6459 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6461 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6462 src
= fold_convert (pvoid_type_node
, src
);
6464 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6466 /* Truncate string if source is too long. */
6467 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6469 tmp2
= build_call_expr_loc (input_location
,
6470 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6471 3, dest
, src
, dlen
);
6473 /* Else copy and pad with spaces. */
6474 tmp3
= build_call_expr_loc (input_location
,
6475 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6476 3, dest
, src
, slen
);
6478 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6479 tmp4
= fill_with_spaces (tmp4
, chartype
,
6480 fold_build2_loc (input_location
, MINUS_EXPR
,
6481 TREE_TYPE(dlen
), dlen
, slen
));
6483 gfc_init_block (&tempblock
);
6484 gfc_add_expr_to_block (&tempblock
, tmp3
);
6485 gfc_add_expr_to_block (&tempblock
, tmp4
);
6486 tmp3
= gfc_finish_block (&tempblock
);
6488 /* The whole copy_string function is there. */
6489 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6491 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6492 build_empty_stmt (input_location
));
6493 gfc_add_expr_to_block (block
, tmp
);
6497 /* Translate a statement function.
6498 The value of a statement function reference is obtained by evaluating the
6499 expression using the values of the actual arguments for the values of the
6500 corresponding dummy arguments. */
6503 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6507 gfc_formal_arglist
*fargs
;
6508 gfc_actual_arglist
*args
;
6511 gfc_saved_var
*saved_vars
;
6517 sym
= expr
->symtree
->n
.sym
;
6518 args
= expr
->value
.function
.actual
;
6519 gfc_init_se (&lse
, NULL
);
6520 gfc_init_se (&rse
, NULL
);
6523 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6525 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6526 temp_vars
= XCNEWVEC (tree
, n
);
6528 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6529 fargs
= fargs
->next
, n
++)
6531 /* Each dummy shall be specified, explicitly or implicitly, to be
6533 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6536 if (fsym
->ts
.type
== BT_CHARACTER
)
6538 /* Copy string arguments. */
6541 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6542 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6544 /* Create a temporary to hold the value. */
6545 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6546 fsym
->ts
.u
.cl
->backend_decl
6547 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6549 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6550 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6552 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6554 gfc_conv_expr (&rse
, args
->expr
);
6555 gfc_conv_string_parameter (&rse
);
6556 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6557 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6559 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6560 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6561 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6562 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6566 /* For everything else, just evaluate the expression. */
6568 /* Create a temporary to hold the value. */
6569 type
= gfc_typenode_for_spec (&fsym
->ts
);
6570 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6572 gfc_conv_expr (&lse
, args
->expr
);
6574 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6575 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6576 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6582 /* Use the temporary variables in place of the real ones. */
6583 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6584 fargs
= fargs
->next
, n
++)
6585 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6587 gfc_conv_expr (se
, sym
->value
);
6589 if (sym
->ts
.type
== BT_CHARACTER
)
6591 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6593 /* Force the expression to the correct length. */
6594 if (!INTEGER_CST_P (se
->string_length
)
6595 || tree_int_cst_lt (se
->string_length
,
6596 sym
->ts
.u
.cl
->backend_decl
))
6598 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6599 tmp
= gfc_create_var (type
, sym
->name
);
6600 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6601 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6602 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6606 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6609 /* Restore the original variables. */
6610 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6611 fargs
= fargs
->next
, n
++)
6612 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6618 /* Translate a function expression. */
6621 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6625 if (expr
->value
.function
.isym
)
6627 gfc_conv_intrinsic_function (se
, expr
);
6631 /* expr.value.function.esym is the resolved (specific) function symbol for
6632 most functions. However this isn't set for dummy procedures. */
6633 sym
= expr
->value
.function
.esym
;
6635 sym
= expr
->symtree
->n
.sym
;
6637 /* The IEEE_ARITHMETIC functions are caught here. */
6638 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6639 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6642 /* We distinguish statement functions from general functions to improve
6643 runtime performance. */
6644 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6646 gfc_conv_statement_function (se
, expr
);
6650 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6655 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6658 is_zero_initializer_p (gfc_expr
* expr
)
6660 if (expr
->expr_type
!= EXPR_CONSTANT
)
6663 /* We ignore constants with prescribed memory representations for now. */
6664 if (expr
->representation
.string
)
6667 switch (expr
->ts
.type
)
6670 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6673 return mpfr_zero_p (expr
->value
.real
)
6674 && MPFR_SIGN (expr
->value
.real
) >= 0;
6677 return expr
->value
.logical
== 0;
6680 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6681 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6682 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6683 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6693 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6698 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6699 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6701 gfc_conv_tmp_array_ref (se
);
6705 /* Build a static initializer. EXPR is the expression for the initial value.
6706 The other parameters describe the variable of the component being
6707 initialized. EXPR may be null. */
6710 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6711 bool array
, bool pointer
, bool procptr
)
6715 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6716 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6717 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6718 return build_constructor (type
, NULL
);
6720 if (!(expr
|| pointer
|| procptr
))
6723 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6724 (these are the only two iso_c_binding derived types that can be
6725 used as initialization expressions). If so, we need to modify
6726 the 'expr' to be that for a (void *). */
6727 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6728 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6730 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6732 /* The derived symbol has already been converted to a (void *). Use
6734 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6735 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6737 gfc_init_se (&se
, NULL
);
6738 gfc_conv_constant (&se
, expr
);
6739 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6743 if (array
&& !procptr
)
6746 /* Arrays need special handling. */
6748 ctor
= gfc_build_null_descriptor (type
);
6749 /* Special case assigning an array to zero. */
6750 else if (is_zero_initializer_p (expr
))
6751 ctor
= build_constructor (type
, NULL
);
6753 ctor
= gfc_conv_array_initializer (type
, expr
);
6754 TREE_STATIC (ctor
) = 1;
6757 else if (pointer
|| procptr
)
6759 if (ts
->type
== BT_CLASS
&& !procptr
)
6761 gfc_init_se (&se
, NULL
);
6762 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6763 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6764 TREE_STATIC (se
.expr
) = 1;
6767 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6768 return fold_convert (type
, null_pointer_node
);
6771 gfc_init_se (&se
, NULL
);
6772 se
.want_pointer
= 1;
6773 gfc_conv_expr (&se
, expr
);
6774 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6784 gfc_init_se (&se
, NULL
);
6785 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6786 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6788 gfc_conv_structure (&se
, expr
, 1);
6789 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6790 TREE_STATIC (se
.expr
) = 1;
6795 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6796 TREE_STATIC (ctor
) = 1;
6801 gfc_init_se (&se
, NULL
);
6802 gfc_conv_constant (&se
, expr
);
6803 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6810 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6816 gfc_array_info
*lss_array
;
6823 gfc_start_block (&block
);
6825 /* Initialize the scalarizer. */
6826 gfc_init_loopinfo (&loop
);
6828 gfc_init_se (&lse
, NULL
);
6829 gfc_init_se (&rse
, NULL
);
6832 rss
= gfc_walk_expr (expr
);
6833 if (rss
== gfc_ss_terminator
)
6834 /* The rhs is scalar. Add a ss for the expression. */
6835 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6837 /* Create a SS for the destination. */
6838 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6840 lss_array
= &lss
->info
->data
.array
;
6841 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6842 lss_array
->descriptor
= dest
;
6843 lss_array
->data
= gfc_conv_array_data (dest
);
6844 lss_array
->offset
= gfc_conv_array_offset (dest
);
6845 for (n
= 0; n
< cm
->as
->rank
; n
++)
6847 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6848 lss_array
->stride
[n
] = gfc_index_one_node
;
6850 mpz_init (lss_array
->shape
[n
]);
6851 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6852 cm
->as
->lower
[n
]->value
.integer
);
6853 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6856 /* Associate the SS with the loop. */
6857 gfc_add_ss_to_loop (&loop
, lss
);
6858 gfc_add_ss_to_loop (&loop
, rss
);
6860 /* Calculate the bounds of the scalarization. */
6861 gfc_conv_ss_startstride (&loop
);
6863 /* Setup the scalarizing loops. */
6864 gfc_conv_loop_setup (&loop
, &expr
->where
);
6866 /* Setup the gfc_se structures. */
6867 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6868 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6871 gfc_mark_ss_chain_used (rss
, 1);
6873 gfc_mark_ss_chain_used (lss
, 1);
6875 /* Start the scalarized loop body. */
6876 gfc_start_scalarized_body (&loop
, &body
);
6878 gfc_conv_tmp_array_ref (&lse
);
6879 if (cm
->ts
.type
== BT_CHARACTER
)
6880 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6882 gfc_conv_expr (&rse
, expr
);
6884 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6885 gfc_add_expr_to_block (&body
, tmp
);
6887 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6889 /* Generate the copying loops. */
6890 gfc_trans_scalarizing_loops (&loop
, &body
);
6892 /* Wrap the whole thing up. */
6893 gfc_add_block_to_block (&block
, &loop
.pre
);
6894 gfc_add_block_to_block (&block
, &loop
.post
);
6896 gcc_assert (lss_array
->shape
!= NULL
);
6897 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6898 gfc_cleanup_loop (&loop
);
6900 return gfc_finish_block (&block
);
6905 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6915 gfc_expr
*arg
= NULL
;
6917 gfc_start_block (&block
);
6918 gfc_init_se (&se
, NULL
);
6920 /* Get the descriptor for the expressions. */
6921 se
.want_pointer
= 0;
6922 gfc_conv_expr_descriptor (&se
, expr
);
6923 gfc_add_block_to_block (&block
, &se
.pre
);
6924 gfc_add_modify (&block
, dest
, se
.expr
);
6926 /* Deal with arrays of derived types with allocatable components. */
6927 if (gfc_bt_struct (cm
->ts
.type
)
6928 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6929 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6932 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6933 && CLASS_DATA(cm
)->attr
.allocatable
)
6935 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6936 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6941 tmp
= TREE_TYPE (dest
);
6942 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6943 tmp
, expr
->rank
, NULL_TREE
);
6947 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6948 TREE_TYPE(cm
->backend_decl
),
6949 cm
->as
->rank
, NULL_TREE
);
6951 gfc_add_expr_to_block (&block
, tmp
);
6952 gfc_add_block_to_block (&block
, &se
.post
);
6954 if (expr
->expr_type
!= EXPR_VARIABLE
)
6955 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6958 /* We need to know if the argument of a conversion function is a
6959 variable, so that the correct lower bound can be used. */
6960 if (expr
->expr_type
== EXPR_FUNCTION
6961 && expr
->value
.function
.isym
6962 && expr
->value
.function
.isym
->conversion
6963 && expr
->value
.function
.actual
->expr
6964 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6965 arg
= expr
->value
.function
.actual
->expr
;
6967 /* Obtain the array spec of full array references. */
6969 as
= gfc_get_full_arrayspec_from_expr (arg
);
6971 as
= gfc_get_full_arrayspec_from_expr (expr
);
6973 /* Shift the lbound and ubound of temporaries to being unity,
6974 rather than zero, based. Always calculate the offset. */
6975 offset
= gfc_conv_descriptor_offset_get (dest
);
6976 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6977 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6979 for (n
= 0; n
< expr
->rank
; n
++)
6984 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6985 TODO It looks as if gfc_conv_expr_descriptor should return
6986 the correct bounds and that the following should not be
6987 necessary. This would simplify gfc_conv_intrinsic_bound
6989 if (as
&& as
->lower
[n
])
6992 gfc_init_se (&lbse
, NULL
);
6993 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6994 gfc_add_block_to_block (&block
, &lbse
.pre
);
6995 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6999 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
7000 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
7004 lbound
= gfc_conv_descriptor_lbound_get (dest
,
7007 lbound
= gfc_index_one_node
;
7009 lbound
= fold_convert (gfc_array_index_type
, lbound
);
7011 /* Shift the bounds and set the offset accordingly. */
7012 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
7013 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7014 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
7015 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7017 gfc_conv_descriptor_ubound_set (&block
, dest
,
7018 gfc_rank_cst
[n
], tmp
);
7019 gfc_conv_descriptor_lbound_set (&block
, dest
,
7020 gfc_rank_cst
[n
], lbound
);
7022 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7023 gfc_conv_descriptor_lbound_get (dest
,
7025 gfc_conv_descriptor_stride_get (dest
,
7027 gfc_add_modify (&block
, tmp2
, tmp
);
7028 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7030 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
7035 /* If a conversion expression has a null data pointer
7036 argument, nullify the allocatable component. */
7040 if (arg
->symtree
->n
.sym
->attr
.allocatable
7041 || arg
->symtree
->n
.sym
->attr
.pointer
)
7043 non_null_expr
= gfc_finish_block (&block
);
7044 gfc_start_block (&block
);
7045 gfc_conv_descriptor_data_set (&block
, dest
,
7047 null_expr
= gfc_finish_block (&block
);
7048 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
7049 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
7050 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
7051 return build3_v (COND_EXPR
, tmp
,
7052 null_expr
, non_null_expr
);
7056 return gfc_finish_block (&block
);
7060 /* Allocate or reallocate scalar component, as necessary. */
7063 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7073 tree lhs_cl_size
= NULL_TREE
;
7078 if (!expr2
|| expr2
->rank
)
7081 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7083 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7085 char name
[GFC_MAX_SYMBOL_LEN
+9];
7086 gfc_component
*strlen
;
7087 /* Use the rhs string length and the lhs element size. */
7088 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7089 if (!expr2
->ts
.u
.cl
->backend_decl
)
7091 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7092 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7095 size
= expr2
->ts
.u
.cl
->backend_decl
;
7097 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7099 sprintf (name
, "_%s_length", cm
->name
);
7100 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7101 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7102 gfc_charlen_type_node
,
7103 TREE_OPERAND (comp
, 0),
7104 strlen
->backend_decl
, NULL_TREE
);
7106 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7107 tmp
= TYPE_SIZE_UNIT (tmp
);
7108 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7109 TREE_TYPE (tmp
), tmp
,
7110 fold_convert (TREE_TYPE (tmp
), size
));
7112 else if (cm
->ts
.type
== BT_CLASS
)
7114 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7115 if (expr2
->ts
.type
== BT_DERIVED
)
7117 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7118 size
= TYPE_SIZE_UNIT (tmp
);
7124 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7125 gfc_add_vptr_component (e2vtab
);
7126 gfc_add_size_component (e2vtab
);
7127 gfc_init_se (&se
, NULL
);
7128 gfc_conv_expr (&se
, e2vtab
);
7129 gfc_add_block_to_block (block
, &se
.pre
);
7130 size
= fold_convert (size_type_node
, se
.expr
);
7131 gfc_free_expr (e2vtab
);
7133 size_in_bytes
= size
;
7137 /* Otherwise use the length in bytes of the rhs. */
7138 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7139 size_in_bytes
= size
;
7142 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7143 size_in_bytes
, size_one_node
);
7145 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7147 tmp
= build_call_expr_loc (input_location
,
7148 builtin_decl_explicit (BUILT_IN_CALLOC
),
7149 2, build_one_cst (size_type_node
),
7151 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7152 gfc_add_modify (block
, comp
, tmp
);
7156 tmp
= build_call_expr_loc (input_location
,
7157 builtin_decl_explicit (BUILT_IN_MALLOC
),
7159 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7160 ptr
= gfc_class_data_get (comp
);
7163 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7164 gfc_add_modify (block
, ptr
, tmp
);
7167 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7168 /* Update the lhs character length. */
7169 gfc_add_modify (block
, lhs_cl_size
, size
);
7173 /* Assign a single component of a derived type constructor. */
7176 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7177 gfc_symbol
*sym
, bool init
)
7185 gfc_start_block (&block
);
7187 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7189 /* Only care about pointers here, not about allocatables. */
7190 gfc_init_se (&se
, NULL
);
7191 /* Pointer component. */
7192 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7193 && !cm
->attr
.proc_pointer
)
7195 /* Array pointer. */
7196 if (expr
->expr_type
== EXPR_NULL
)
7197 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7200 se
.direct_byref
= 1;
7202 gfc_conv_expr_descriptor (&se
, expr
);
7203 gfc_add_block_to_block (&block
, &se
.pre
);
7204 gfc_add_block_to_block (&block
, &se
.post
);
7209 /* Scalar pointers. */
7210 se
.want_pointer
= 1;
7211 gfc_conv_expr (&se
, expr
);
7212 gfc_add_block_to_block (&block
, &se
.pre
);
7214 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7215 && expr
->symtree
->n
.sym
->attr
.dummy
)
7216 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7218 gfc_add_modify (&block
, dest
,
7219 fold_convert (TREE_TYPE (dest
), se
.expr
));
7220 gfc_add_block_to_block (&block
, &se
.post
);
7223 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7225 /* NULL initialization for CLASS components. */
7226 tmp
= gfc_trans_structure_assign (dest
,
7227 gfc_class_initializer (&cm
->ts
, expr
),
7229 gfc_add_expr_to_block (&block
, tmp
);
7231 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7232 && !cm
->attr
.proc_pointer
)
7234 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7235 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7236 else if (cm
->attr
.allocatable
)
7238 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7239 gfc_add_expr_to_block (&block
, tmp
);
7243 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7244 gfc_add_expr_to_block (&block
, tmp
);
7247 else if (cm
->ts
.type
== BT_CLASS
7248 && CLASS_DATA (cm
)->attr
.dimension
7249 && CLASS_DATA (cm
)->attr
.allocatable
7250 && expr
->ts
.type
== BT_DERIVED
)
7252 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7253 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7254 tmp
= gfc_class_vptr_get (dest
);
7255 gfc_add_modify (&block
, tmp
,
7256 fold_convert (TREE_TYPE (tmp
), vtab
));
7257 tmp
= gfc_class_data_get (dest
);
7258 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7259 gfc_add_expr_to_block (&block
, tmp
);
7261 else if (init
&& cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7263 /* NULL initialization for allocatable components. */
7264 gfc_add_modify (&block
, dest
, fold_convert (TREE_TYPE (dest
),
7265 null_pointer_node
));
7267 else if (init
&& (cm
->attr
.allocatable
7268 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7269 && expr
->ts
.type
!= BT_CLASS
)))
7271 /* Take care about non-array allocatable components here. The alloc_*
7272 routine below is motivated by the alloc_scalar_allocatable_for_
7273 assignment() routine, but with the realloc portions removed and
7275 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7280 /* The remainder of these instructions follow the if (cm->attr.pointer)
7281 if (!cm->attr.dimension) part above. */
7282 gfc_init_se (&se
, NULL
);
7283 gfc_conv_expr (&se
, expr
);
7284 gfc_add_block_to_block (&block
, &se
.pre
);
7286 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7287 && expr
->symtree
->n
.sym
->attr
.dummy
)
7288 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7290 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7292 tmp
= gfc_class_data_get (dest
);
7293 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7294 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7295 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7296 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7297 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7300 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7302 /* For deferred strings insert a memcpy. */
7303 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7306 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7307 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7309 : expr
->ts
.u
.cl
->backend_decl
);
7310 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7311 gfc_add_expr_to_block (&block
, tmp
);
7314 gfc_add_modify (&block
, tmp
,
7315 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7316 gfc_add_block_to_block (&block
, &se
.post
);
7318 else if (gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.f90_type
!= BT_VOID
)
7320 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7322 tree dealloc
= NULL_TREE
;
7323 gfc_init_se (&se
, NULL
);
7324 gfc_conv_expr (&se
, expr
);
7325 gfc_add_block_to_block (&block
, &se
.pre
);
7326 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7327 expression in a temporary variable and deallocate the allocatable
7328 components. Then we can the copy the expression to the result. */
7329 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7330 && expr
->expr_type
!= EXPR_VARIABLE
)
7332 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7333 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7336 gfc_add_modify (&block
, dest
,
7337 fold_convert (TREE_TYPE (dest
), se
.expr
));
7338 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7339 && expr
->expr_type
!= EXPR_NULL
)
7341 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7343 gfc_add_expr_to_block (&block
, tmp
);
7344 if (dealloc
!= NULL_TREE
)
7345 gfc_add_expr_to_block (&block
, dealloc
);
7347 gfc_add_block_to_block (&block
, &se
.post
);
7351 /* Nested constructors. */
7352 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7353 gfc_add_expr_to_block (&block
, tmp
);
7356 else if (gfc_deferred_strlen (cm
, &tmp
))
7360 gcc_assert (strlen
);
7361 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7363 TREE_OPERAND (dest
, 0),
7366 if (expr
->expr_type
== EXPR_NULL
)
7368 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7369 gfc_add_modify (&block
, dest
, tmp
);
7370 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7371 gfc_add_modify (&block
, strlen
, tmp
);
7376 gfc_init_se (&se
, NULL
);
7377 gfc_conv_expr (&se
, expr
);
7378 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7379 tmp
= build_call_expr_loc (input_location
,
7380 builtin_decl_explicit (BUILT_IN_MALLOC
),
7382 gfc_add_modify (&block
, dest
,
7383 fold_convert (TREE_TYPE (dest
), tmp
));
7384 gfc_add_modify (&block
, strlen
, se
.string_length
);
7385 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7386 gfc_add_expr_to_block (&block
, tmp
);
7389 else if (!cm
->attr
.artificial
)
7391 /* Scalar component (excluding deferred parameters). */
7392 gfc_init_se (&se
, NULL
);
7393 gfc_init_se (&lse
, NULL
);
7395 gfc_conv_expr (&se
, expr
);
7396 if (cm
->ts
.type
== BT_CHARACTER
)
7397 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7399 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7400 gfc_add_expr_to_block (&block
, tmp
);
7402 return gfc_finish_block (&block
);
7405 /* Assign a derived type constructor to a variable. */
7408 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7416 gfc_start_block (&block
);
7417 cm
= expr
->ts
.u
.derived
->components
;
7419 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7420 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7421 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7425 gfc_init_se (&se
, NULL
);
7426 gfc_init_se (&lse
, NULL
);
7427 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7429 gfc_add_modify (&block
, lse
.expr
,
7430 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7432 return gfc_finish_block (&block
);
7435 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7436 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7438 /* Skip absent members in default initializers. */
7439 if (!c
->expr
&& !cm
->attr
.allocatable
)
7442 field
= cm
->backend_decl
;
7443 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7444 dest
, field
, NULL_TREE
);
7447 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7448 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7453 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7454 expr
->ts
.u
.derived
, init
);
7455 gfc_add_expr_to_block (&block
, tmp
);
7457 return gfc_finish_block (&block
);
7460 /* Build an expression for a constructor. If init is nonzero then
7461 this is part of a static variable initializer. */
7464 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7471 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7473 gcc_assert (se
->ss
== NULL
);
7474 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7475 type
= gfc_typenode_for_spec (&expr
->ts
);
7479 /* Create a temporary variable and fill it in. */
7480 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7481 /* The symtree in expr is NULL, if the code to generate is for
7482 initializing the static members only. */
7483 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7484 gfc_add_expr_to_block (&se
->pre
, tmp
);
7488 /* Though unions appear to have multiple map components, they must only
7489 have a single initializer since each map overlaps. TODO: squash map
7491 if (expr
->ts
.type
== BT_UNION
)
7493 c
= gfc_constructor_first (expr
->value
.constructor
);
7494 cm
= c
->n
.component
;
7495 val
= gfc_conv_initializer (c
->expr
, &expr
->ts
,
7496 TREE_TYPE (cm
->backend_decl
),
7497 cm
->attr
.dimension
, cm
->attr
.pointer
,
7498 cm
->attr
.proc_pointer
);
7499 val
= unshare_expr_without_location (val
);
7501 /* Append it to the constructor list. */
7502 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7506 cm
= expr
->ts
.u
.derived
->components
;
7508 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7509 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7511 /* Skip absent members in default initializers and allocatable
7512 components. Although the latter have a default initializer
7513 of EXPR_NULL,... by default, the static nullify is not needed
7514 since this is done every time we come into scope. */
7515 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7518 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7519 && strcmp (cm
->name
, "_extends") == 0
7520 && cm
->initializer
->symtree
)
7524 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7525 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7526 vtab
= unshare_expr_without_location (vtab
);
7527 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7529 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7531 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7532 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7533 fold_convert (TREE_TYPE (cm
->backend_decl
),
7536 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7537 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7538 fold_convert (TREE_TYPE (cm
->backend_decl
),
7539 integer_zero_node
));
7542 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7543 TREE_TYPE (cm
->backend_decl
),
7544 cm
->attr
.dimension
, cm
->attr
.pointer
,
7545 cm
->attr
.proc_pointer
);
7546 val
= unshare_expr_without_location (val
);
7548 /* Append it to the constructor list. */
7549 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7553 se
->expr
= build_constructor (type
, v
);
7555 TREE_CONSTANT (se
->expr
) = 1;
7559 /* Translate a substring expression. */
7562 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7568 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7570 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7571 expr
->value
.character
.length
,
7572 expr
->value
.character
.string
);
7574 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7575 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7578 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7582 /* Entry point for expression translation. Evaluates a scalar quantity.
7583 EXPR is the expression to be translated, and SE is the state structure if
7584 called from within the scalarized. */
7587 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7592 if (ss
&& ss
->info
->expr
== expr
7593 && (ss
->info
->type
== GFC_SS_SCALAR
7594 || ss
->info
->type
== GFC_SS_REFERENCE
))
7596 gfc_ss_info
*ss_info
;
7599 /* Substitute a scalar expression evaluated outside the scalarization
7601 se
->expr
= ss_info
->data
.scalar
.value
;
7602 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7603 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7605 se
->string_length
= ss_info
->string_length
;
7606 gfc_advance_se_ss_chain (se
);
7610 /* We need to convert the expressions for the iso_c_binding derived types.
7611 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7612 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7613 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7614 updated to be an integer with a kind equal to the size of a (void *). */
7615 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7616 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7618 if (expr
->expr_type
== EXPR_VARIABLE
7619 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7620 || expr
->symtree
->n
.sym
->intmod_sym_id
7621 == ISOCBINDING_NULL_FUNPTR
))
7623 /* Set expr_type to EXPR_NULL, which will result in
7624 null_pointer_node being used below. */
7625 expr
->expr_type
= EXPR_NULL
;
7629 /* Update the type/kind of the expression to be what the new
7630 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7631 expr
->ts
.type
= BT_INTEGER
;
7632 expr
->ts
.f90_type
= BT_VOID
;
7633 expr
->ts
.kind
= gfc_index_integer_kind
;
7637 gfc_fix_class_refs (expr
);
7639 switch (expr
->expr_type
)
7642 gfc_conv_expr_op (se
, expr
);
7646 gfc_conv_function_expr (se
, expr
);
7650 gfc_conv_constant (se
, expr
);
7654 gfc_conv_variable (se
, expr
);
7658 se
->expr
= null_pointer_node
;
7661 case EXPR_SUBSTRING
:
7662 gfc_conv_substring_expr (se
, expr
);
7665 case EXPR_STRUCTURE
:
7666 gfc_conv_structure (se
, expr
, 0);
7670 gfc_conv_array_constructor_expr (se
, expr
);
7679 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7680 of an assignment. */
7682 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7684 gfc_conv_expr (se
, expr
);
7685 /* All numeric lvalues should have empty post chains. If not we need to
7686 figure out a way of rewriting an lvalue so that it has no post chain. */
7687 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7690 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7691 numeric expressions. Used for scalar values where inserting cleanup code
7694 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7698 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7699 gfc_conv_expr (se
, expr
);
7702 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7703 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7705 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7709 /* Helper to translate an expression and convert it to a particular type. */
7711 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7713 gfc_conv_expr_val (se
, expr
);
7714 se
->expr
= convert (type
, se
->expr
);
7718 /* Converts an expression so that it can be passed by reference. Scalar
7722 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7728 if (ss
&& ss
->info
->expr
== expr
7729 && ss
->info
->type
== GFC_SS_REFERENCE
)
7731 /* Returns a reference to the scalar evaluated outside the loop
7733 gfc_conv_expr (se
, expr
);
7735 if (expr
->ts
.type
== BT_CHARACTER
7736 && expr
->expr_type
!= EXPR_FUNCTION
)
7737 gfc_conv_string_parameter (se
);
7739 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7744 if (expr
->ts
.type
== BT_CHARACTER
)
7746 gfc_conv_expr (se
, expr
);
7747 gfc_conv_string_parameter (se
);
7751 if (expr
->expr_type
== EXPR_VARIABLE
)
7753 se
->want_pointer
= 1;
7754 gfc_conv_expr (se
, expr
);
7757 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7758 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7759 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7765 if (expr
->expr_type
== EXPR_FUNCTION
7766 && ((expr
->value
.function
.esym
7767 && expr
->value
.function
.esym
->result
->attr
.pointer
7768 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7769 || (!expr
->value
.function
.esym
&& !expr
->ref
7770 && expr
->symtree
->n
.sym
->attr
.pointer
7771 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7773 se
->want_pointer
= 1;
7774 gfc_conv_expr (se
, expr
);
7775 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7776 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7781 gfc_conv_expr (se
, expr
);
7783 /* Create a temporary var to hold the value. */
7784 if (TREE_CONSTANT (se
->expr
))
7786 tree tmp
= se
->expr
;
7787 STRIP_TYPE_NOPS (tmp
);
7788 var
= build_decl (input_location
,
7789 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7790 DECL_INITIAL (var
) = tmp
;
7791 TREE_STATIC (var
) = 1;
7796 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7797 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7799 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7801 /* Take the address of that value. */
7802 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7806 /* Get the _len component for an unlimited polymorphic expression. */
7809 trans_get_upoly_len (stmtblock_t
*block
, gfc_expr
*expr
)
7812 gfc_ref
*ref
= expr
->ref
;
7814 gfc_init_se (&se
, NULL
);
7815 while (ref
&& ref
->next
)
7817 gfc_add_len_component (expr
);
7818 gfc_conv_expr (&se
, expr
);
7819 gfc_add_block_to_block (block
, &se
.pre
);
7820 gcc_assert (se
.post
.head
== NULL_TREE
);
7823 gfc_free_ref_list (ref
->next
);
7828 gfc_free_ref_list (expr
->ref
);
7835 /* Assign _vptr and _len components as appropriate. BLOCK should be a
7836 statement-list outside of the scalarizer-loop. When code is generated, that
7837 depends on the scalarized expression, it is added to RSE.PRE.
7838 Returns le's _vptr tree and when set the len expressions in to_lenp and
7839 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
7843 trans_class_vptr_len_assignment (stmtblock_t
*block
, gfc_expr
* le
,
7844 gfc_expr
* re
, gfc_se
*rse
,
7845 tree
* to_lenp
, tree
* from_lenp
)
7848 gfc_expr
* vptr_expr
;
7849 tree tmp
, to_len
= NULL_TREE
, from_len
= NULL_TREE
, lhs_vptr
;
7850 bool set_vptr
= false, temp_rhs
= false;
7851 stmtblock_t
*pre
= block
;
7853 /* Create a temporary for complicated expressions. */
7854 if (re
->expr_type
!= EXPR_VARIABLE
&& re
->expr_type
!= EXPR_NULL
7855 && rse
->expr
!= NULL_TREE
&& !DECL_P (rse
->expr
))
7857 tmp
= gfc_create_var (TREE_TYPE (rse
->expr
), "rhs");
7859 gfc_add_modify (&rse
->pre
, tmp
, rse
->expr
);
7864 /* Get the _vptr for the left-hand side expression. */
7865 gfc_init_se (&se
, NULL
);
7866 vptr_expr
= gfc_find_and_cut_at_last_class_ref (le
);
7867 if (vptr_expr
!= NULL
&& gfc_expr_attr (vptr_expr
).class_ok
)
7869 /* Care about _len for unlimited polymorphic entities. */
7870 if (UNLIMITED_POLY (vptr_expr
)
7871 || (vptr_expr
->ts
.type
== BT_DERIVED
7872 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7873 to_len
= trans_get_upoly_len (block
, vptr_expr
);
7874 gfc_add_vptr_component (vptr_expr
);
7878 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
7879 se
.want_pointer
= 1;
7880 gfc_conv_expr (&se
, vptr_expr
);
7881 gfc_free_expr (vptr_expr
);
7882 gfc_add_block_to_block (block
, &se
.pre
);
7883 gcc_assert (se
.post
.head
== NULL_TREE
);
7885 STRIP_NOPS (lhs_vptr
);
7887 /* Set the _vptr only when the left-hand side of the assignment is a
7891 /* Get the vptr from the rhs expression only, when it is variable.
7892 Functions are expected to be assigned to a temporary beforehand. */
7893 vptr_expr
= re
->expr_type
== EXPR_VARIABLE
7894 ? gfc_find_and_cut_at_last_class_ref (re
)
7896 if (vptr_expr
!= NULL
&& vptr_expr
->ts
.type
== BT_CLASS
)
7898 if (to_len
!= NULL_TREE
)
7900 /* Get the _len information from the rhs. */
7901 if (UNLIMITED_POLY (vptr_expr
)
7902 || (vptr_expr
->ts
.type
== BT_DERIVED
7903 && vptr_expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7904 from_len
= trans_get_upoly_len (block
, vptr_expr
);
7906 gfc_add_vptr_component (vptr_expr
);
7910 if (re
->expr_type
== EXPR_VARIABLE
7911 && DECL_P (re
->symtree
->n
.sym
->backend_decl
)
7912 && DECL_LANG_SPECIFIC (re
->symtree
->n
.sym
->backend_decl
)
7913 && GFC_DECL_SAVED_DESCRIPTOR (re
->symtree
->n
.sym
->backend_decl
)
7914 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
7915 re
->symtree
->n
.sym
->backend_decl
))))
7918 se
.expr
= gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
7919 re
->symtree
->n
.sym
->backend_decl
));
7921 from_len
= gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
7922 re
->symtree
->n
.sym
->backend_decl
));
7924 else if (temp_rhs
&& re
->ts
.type
== BT_CLASS
)
7927 se
.expr
= gfc_class_vptr_get (rse
->expr
);
7929 else if (re
->expr_type
!= EXPR_NULL
)
7930 /* Only when rhs is non-NULL use its declared type for vptr
7932 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&re
->ts
));
7934 /* When the rhs is NULL use the vtab of lhs' declared type. */
7935 vptr_expr
= gfc_lval_expr_from_sym (gfc_find_vtab (&le
->ts
));
7940 gfc_init_se (&se
, NULL
);
7941 se
.want_pointer
= 1;
7942 gfc_conv_expr (&se
, vptr_expr
);
7943 gfc_free_expr (vptr_expr
);
7944 gfc_add_block_to_block (block
, &se
.pre
);
7945 gcc_assert (se
.post
.head
== NULL_TREE
);
7947 gfc_add_modify (pre
, lhs_vptr
, fold_convert (TREE_TYPE (lhs_vptr
),
7950 if (to_len
!= NULL_TREE
)
7952 /* The _len component needs to be set. Figure how to get the
7953 value of the right-hand side. */
7954 if (from_len
== NULL_TREE
)
7956 if (rse
->string_length
!= NULL_TREE
)
7957 from_len
= rse
->string_length
;
7958 else if (re
->ts
.type
== BT_CHARACTER
&& re
->ts
.u
.cl
->length
)
7960 from_len
= gfc_get_expr_charlen (re
);
7961 gfc_init_se (&se
, NULL
);
7962 gfc_conv_expr (&se
, re
->ts
.u
.cl
->length
);
7963 gfc_add_block_to_block (block
, &se
.pre
);
7964 gcc_assert (se
.post
.head
== NULL_TREE
);
7965 from_len
= gfc_evaluate_now (se
.expr
, block
);
7968 from_len
= integer_zero_node
;
7970 gfc_add_modify (pre
, to_len
, fold_convert (TREE_TYPE (to_len
),
7975 /* Return the _len trees only, when requested. */
7979 *from_lenp
= from_len
;
7983 /* Indentify class valued proc_pointer assignments. */
7986 pointer_assignment_is_proc_pointer (gfc_expr
* expr1
, gfc_expr
* expr2
)
7991 while (ref
&& ref
->next
)
7994 return ref
&& ref
->type
== REF_COMPONENT
7995 && ref
->u
.c
.component
->attr
.proc_pointer
7996 && expr2
->expr_type
== EXPR_VARIABLE
7997 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
;
8002 gfc_trans_pointer_assign (gfc_code
* code
)
8004 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
8008 /* Generate code for a pointer assignment. */
8011 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
8019 bool scalar
, non_proc_pointer_assign
;
8022 gfc_start_block (&block
);
8024 gfc_init_se (&lse
, NULL
);
8026 /* Usually testing whether this is not a proc pointer assignment. */
8027 non_proc_pointer_assign
= !pointer_assignment_is_proc_pointer (expr1
, expr2
);
8029 /* Check whether the expression is a scalar or not; we cannot use
8030 expr1->rank as it can be nonzero for proc pointers. */
8031 ss
= gfc_walk_expr (expr1
);
8032 scalar
= ss
== gfc_ss_terminator
;
8034 gfc_free_ss_chain (ss
);
8036 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
8037 && expr2
->expr_type
!= EXPR_FUNCTION
&& non_proc_pointer_assign
)
8039 gfc_add_data_component (expr2
);
8040 /* The following is required as gfc_add_data_component doesn't
8041 update ts.type if there is a tailing REF_ARRAY. */
8042 expr2
->ts
.type
= BT_DERIVED
;
8047 /* Scalar pointers. */
8048 lse
.want_pointer
= 1;
8049 gfc_conv_expr (&lse
, expr1
);
8050 gfc_init_se (&rse
, NULL
);
8051 rse
.want_pointer
= 1;
8052 gfc_conv_expr (&rse
, expr2
);
8054 if (non_proc_pointer_assign
&& expr1
->ts
.type
== BT_CLASS
)
8056 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
, NULL
,
8058 lse
.expr
= gfc_class_data_get (lse
.expr
);
8061 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
8062 && expr1
->symtree
->n
.sym
->attr
.dummy
)
8063 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
8066 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
8067 && expr2
->symtree
->n
.sym
->attr
.dummy
)
8068 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
8071 gfc_add_block_to_block (&block
, &lse
.pre
);
8072 gfc_add_block_to_block (&block
, &rse
.pre
);
8074 /* Check character lengths if character expression. The test is only
8075 really added if -fbounds-check is enabled. Exclude deferred
8076 character length lefthand sides. */
8077 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
8078 && !expr1
->ts
.deferred
8079 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
8080 && !gfc_is_proc_ptr_comp (expr1
))
8082 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8083 gcc_assert (lse
.string_length
&& rse
.string_length
);
8084 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8085 lse
.string_length
, rse
.string_length
,
8089 /* The assignment to an deferred character length sets the string
8090 length to that of the rhs. */
8091 if (expr1
->ts
.deferred
)
8093 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
8094 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
8095 else if (lse
.string_length
!= NULL
)
8096 gfc_add_modify (&block
, lse
.string_length
,
8097 build_int_cst (gfc_charlen_type_node
, 0));
8100 gfc_add_modify (&block
, lse
.expr
,
8101 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
8103 gfc_add_block_to_block (&block
, &rse
.post
);
8104 gfc_add_block_to_block (&block
, &lse
.post
);
8110 tree expr1_vptr
= NULL_TREE
;
8112 tree strlen_rhs
= NULL_TREE
;
8114 /* Array pointer. Find the last reference on the LHS and if it is an
8115 array section ref, we're dealing with bounds remapping. In this case,
8116 set it to AR_FULL so that gfc_conv_expr_descriptor does
8117 not see it and process the bounds remapping afterwards explicitly. */
8118 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
8119 if (!remap
->next
&& remap
->type
== REF_ARRAY
8120 && remap
->u
.ar
.type
== AR_SECTION
)
8122 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
8124 gfc_init_se (&lse
, NULL
);
8126 lse
.descriptor_only
= 1;
8127 gfc_conv_expr_descriptor (&lse
, expr1
);
8128 strlen_lhs
= lse
.string_length
;
8131 if (expr2
->expr_type
== EXPR_NULL
)
8133 /* Just set the data pointer to null. */
8134 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
8136 else if (rank_remap
)
8138 /* If we are rank-remapping, just get the RHS's descriptor and
8139 process this later on. */
8140 gfc_init_se (&rse
, NULL
);
8141 rse
.direct_byref
= 1;
8142 rse
.byref_noassign
= 1;
8144 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8146 gfc_conv_function_expr (&rse
, expr2
);
8148 if (expr1
->ts
.type
!= BT_CLASS
)
8149 rse
.expr
= gfc_class_data_get (rse
.expr
);
8152 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8155 gfc_add_block_to_block (&block
, &rse
.pre
);
8156 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8157 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8159 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8160 fold_convert (TREE_TYPE (expr1_vptr
),
8161 gfc_class_vptr_get (tmp
)));
8162 rse
.expr
= gfc_class_data_get (tmp
);
8165 else if (expr2
->expr_type
== EXPR_FUNCTION
)
8167 tree bound
[GFC_MAX_DIMENSIONS
];
8170 for (i
= 0; i
< expr2
->rank
; i
++)
8171 bound
[i
] = NULL_TREE
;
8172 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
8173 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
8175 GFC_ARRAY_POINTER_CONT
, false);
8176 tmp
= gfc_create_var (tmp
, "ptrtemp");
8177 rse
.descriptor_only
= 0;
8179 rse
.direct_byref
= 1;
8180 gfc_conv_expr_descriptor (&rse
, expr2
);
8181 strlen_rhs
= rse
.string_length
;
8186 gfc_conv_expr_descriptor (&rse
, expr2
);
8187 strlen_rhs
= rse
.string_length
;
8188 if (expr1
->ts
.type
== BT_CLASS
)
8189 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8194 else if (expr2
->expr_type
== EXPR_VARIABLE
)
8196 /* Assign directly to the LHS's descriptor. */
8197 lse
.descriptor_only
= 0;
8198 lse
.direct_byref
= 1;
8199 gfc_conv_expr_descriptor (&lse
, expr2
);
8200 strlen_rhs
= lse
.string_length
;
8202 /* If this is a subreference array pointer assignment, use the rhs
8203 descriptor element size for the lhs span. */
8204 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
8206 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
8207 gfc_init_se (&rse
, NULL
);
8208 rse
.descriptor_only
= 1;
8209 gfc_conv_expr (&rse
, expr2
);
8210 if (expr1
->ts
.type
== BT_CLASS
)
8211 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8213 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
8214 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
8215 if (!INTEGER_CST_P (tmp
))
8216 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
8217 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
8219 else if (expr1
->ts
.type
== BT_CLASS
)
8221 rse
.expr
= NULL_TREE
;
8222 rse
.string_length
= NULL_TREE
;
8223 trans_class_vptr_len_assignment (&block
, expr1
, expr2
, &rse
,
8227 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
8229 gfc_init_se (&rse
, NULL
);
8230 rse
.want_pointer
= 1;
8231 gfc_conv_function_expr (&rse
, expr2
);
8232 if (expr1
->ts
.type
!= BT_CLASS
)
8234 rse
.expr
= gfc_class_data_get (rse
.expr
);
8235 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8239 expr1_vptr
= trans_class_vptr_len_assignment (&block
, expr1
,
8242 gfc_add_block_to_block (&block
, &rse
.pre
);
8243 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
8244 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
8246 gfc_add_modify (&lse
.pre
, expr1_vptr
,
8247 fold_convert (TREE_TYPE (expr1_vptr
),
8248 gfc_class_vptr_get (tmp
)));
8249 rse
.expr
= gfc_class_data_get (tmp
);
8250 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8255 /* Assign to a temporary descriptor and then copy that
8256 temporary to the pointer. */
8257 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8258 lse
.descriptor_only
= 0;
8260 lse
.direct_byref
= 1;
8261 gfc_conv_expr_descriptor (&lse
, expr2
);
8262 strlen_rhs
= lse
.string_length
;
8263 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8266 gfc_add_block_to_block (&block
, &lse
.pre
);
8268 gfc_add_block_to_block (&block
, &rse
.pre
);
8270 /* If we do bounds remapping, update LHS descriptor accordingly. */
8274 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8278 /* Do rank remapping. We already have the RHS's descriptor
8279 converted in rse and now have to build the correct LHS
8280 descriptor for it. */
8284 tree lbound
, ubound
;
8287 dtype
= gfc_conv_descriptor_dtype (desc
);
8288 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8289 gfc_add_modify (&block
, dtype
, tmp
);
8291 /* Copy data pointer. */
8292 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8293 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8295 /* Copy offset but adjust it such that it would correspond
8296 to a lbound of zero. */
8297 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8298 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8300 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8302 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8304 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8305 gfc_array_index_type
, stride
, lbound
);
8306 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8307 gfc_array_index_type
, offs
, tmp
);
8309 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8311 /* Set the bounds as declared for the LHS and calculate strides as
8312 well as another offset update accordingly. */
8313 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8315 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8320 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8322 /* Convert declared bounds. */
8323 gfc_init_se (&lower_se
, NULL
);
8324 gfc_init_se (&upper_se
, NULL
);
8325 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8326 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8328 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8329 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8331 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8332 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8334 lbound
= gfc_evaluate_now (lbound
, &block
);
8335 ubound
= gfc_evaluate_now (ubound
, &block
);
8337 gfc_add_block_to_block (&block
, &lower_se
.post
);
8338 gfc_add_block_to_block (&block
, &upper_se
.post
);
8340 /* Set bounds in descriptor. */
8341 gfc_conv_descriptor_lbound_set (&block
, desc
,
8342 gfc_rank_cst
[dim
], lbound
);
8343 gfc_conv_descriptor_ubound_set (&block
, desc
,
8344 gfc_rank_cst
[dim
], ubound
);
8347 stride
= gfc_evaluate_now (stride
, &block
);
8348 gfc_conv_descriptor_stride_set (&block
, desc
,
8349 gfc_rank_cst
[dim
], stride
);
8351 /* Update offset. */
8352 offs
= gfc_conv_descriptor_offset_get (desc
);
8353 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8354 gfc_array_index_type
, lbound
, stride
);
8355 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8356 gfc_array_index_type
, offs
, tmp
);
8357 offs
= gfc_evaluate_now (offs
, &block
);
8358 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8360 /* Update stride. */
8361 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8362 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8363 gfc_array_index_type
, stride
, tmp
);
8368 /* Bounds remapping. Just shift the lower bounds. */
8370 gcc_assert (expr1
->rank
== expr2
->rank
);
8372 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8376 gcc_assert (remap
->u
.ar
.start
[dim
]);
8377 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8378 gfc_init_se (&lbound_se
, NULL
);
8379 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8381 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8382 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8383 dim
, lbound_se
.expr
);
8384 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8389 /* Check string lengths if applicable. The check is only really added
8390 to the output code if -fbounds-check is enabled. */
8391 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8393 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8394 gcc_assert (strlen_lhs
&& strlen_rhs
);
8395 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8396 strlen_lhs
, strlen_rhs
, &block
);
8399 /* If rank remapping was done, check with -fcheck=bounds that
8400 the target is at least as large as the pointer. */
8401 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8407 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8408 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8410 lsize
= gfc_evaluate_now (lsize
, &block
);
8411 rsize
= gfc_evaluate_now (rsize
, &block
);
8412 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8415 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8416 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8420 gfc_add_block_to_block (&block
, &lse
.post
);
8422 gfc_add_block_to_block (&block
, &rse
.post
);
8425 return gfc_finish_block (&block
);
8429 /* Makes sure se is suitable for passing as a function string parameter. */
8430 /* TODO: Need to check all callers of this function. It may be abused. */
8433 gfc_conv_string_parameter (gfc_se
* se
)
8437 if (TREE_CODE (se
->expr
) == STRING_CST
)
8439 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8440 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8444 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8446 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8448 type
= TREE_TYPE (se
->expr
);
8449 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8453 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8455 type
= build_pointer_type (type
);
8456 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8460 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8464 /* Generate code for assignment of scalar variables. Includes character
8465 strings and derived types with allocatable components.
8466 If you know that the LHS has no allocations, set dealloc to false.
8468 DEEP_COPY has no effect if the typespec TS is not a derived type with
8469 allocatable components. Otherwise, if it is set, an explicit copy of each
8470 allocatable component is made. This is necessary as a simple copy of the
8471 whole object would copy array descriptors as is, so that the lhs's
8472 allocatable components would point to the rhs's after the assignment.
8473 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8474 necessary if the rhs is a non-pointer function, as the allocatable components
8475 are not accessible by other means than the function's result after the
8476 function has returned. It is even more subtle when temporaries are involved,
8477 as the two following examples show:
8478 1. When we evaluate an array constructor, a temporary is created. Thus
8479 there is theoretically no alias possible. However, no deep copy is
8480 made for this temporary, so that if the constructor is made of one or
8481 more variable with allocatable components, those components still point
8482 to the variable's: DEEP_COPY should be set for the assignment from the
8483 temporary to the lhs in that case.
8484 2. When assigning a scalar to an array, we evaluate the scalar value out
8485 of the loop, store it into a temporary variable, and assign from that.
8486 In that case, deep copying when assigning to the temporary would be a
8487 waste of resources; however deep copies should happen when assigning from
8488 the temporary to each array element: again DEEP_COPY should be set for
8489 the assignment from the temporary to the lhs. */
8492 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8493 bool deep_copy
, bool dealloc
)
8499 gfc_init_block (&block
);
8501 if (ts
.type
== BT_CHARACTER
)
8506 if (lse
->string_length
!= NULL_TREE
)
8508 gfc_conv_string_parameter (lse
);
8509 gfc_add_block_to_block (&block
, &lse
->pre
);
8510 llen
= lse
->string_length
;
8513 if (rse
->string_length
!= NULL_TREE
)
8515 gfc_conv_string_parameter (rse
);
8516 gfc_add_block_to_block (&block
, &rse
->pre
);
8517 rlen
= rse
->string_length
;
8520 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8521 rse
->expr
, ts
.kind
);
8523 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8525 tree tmp_var
= NULL_TREE
;
8528 /* Are the rhs and the lhs the same? */
8531 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8532 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8533 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8534 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8537 /* Deallocate the lhs allocated components as long as it is not
8538 the same as the rhs. This must be done following the assignment
8539 to prevent deallocating data that could be used in the rhs
8543 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8544 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8546 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8548 gfc_add_expr_to_block (&lse
->post
, tmp
);
8551 gfc_add_block_to_block (&block
, &rse
->pre
);
8552 gfc_add_block_to_block (&block
, &lse
->pre
);
8554 gfc_add_modify (&block
, lse
->expr
,
8555 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8557 /* Restore pointer address of coarray components. */
8558 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8560 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8561 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8563 gfc_add_expr_to_block (&block
, tmp
);
8566 /* Do a deep copy if the rhs is a variable, if it is not the
8570 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8571 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8573 gfc_add_expr_to_block (&block
, tmp
);
8576 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8578 gfc_add_block_to_block (&block
, &lse
->pre
);
8579 gfc_add_block_to_block (&block
, &rse
->pre
);
8580 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8581 TREE_TYPE (lse
->expr
), rse
->expr
);
8582 gfc_add_modify (&block
, lse
->expr
, tmp
);
8586 gfc_add_block_to_block (&block
, &lse
->pre
);
8587 gfc_add_block_to_block (&block
, &rse
->pre
);
8589 gfc_add_modify (&block
, lse
->expr
,
8590 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8593 gfc_add_block_to_block (&block
, &lse
->post
);
8594 gfc_add_block_to_block (&block
, &rse
->post
);
8596 return gfc_finish_block (&block
);
8600 /* There are quite a lot of restrictions on the optimisation in using an
8601 array function assign without a temporary. */
8604 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8607 bool seen_array_ref
;
8609 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8611 /* Play it safe with class functions assigned to a derived type. */
8612 if (gfc_is_alloc_class_array_function (expr2
)
8613 && expr1
->ts
.type
== BT_DERIVED
)
8616 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8617 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8620 /* Elemental functions are scalarized so that they don't need a
8621 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8622 they would need special treatment in gfc_trans_arrayfunc_assign. */
8623 if (expr2
->value
.function
.esym
!= NULL
8624 && expr2
->value
.function
.esym
->attr
.elemental
)
8627 /* Need a temporary if rhs is not FULL or a contiguous section. */
8628 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8631 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8632 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8635 /* Functions returning pointers or allocatables need temporaries. */
8636 c
= expr2
->value
.function
.esym
8637 ? (expr2
->value
.function
.esym
->attr
.pointer
8638 || expr2
->value
.function
.esym
->attr
.allocatable
)
8639 : (expr2
->symtree
->n
.sym
->attr
.pointer
8640 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8644 /* Character array functions need temporaries unless the
8645 character lengths are the same. */
8646 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8648 if (expr1
->ts
.u
.cl
->length
== NULL
8649 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8652 if (expr2
->ts
.u
.cl
->length
== NULL
8653 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8656 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8657 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8661 /* Check that no LHS component references appear during an array
8662 reference. This is needed because we do not have the means to
8663 span any arbitrary stride with an array descriptor. This check
8664 is not needed for the rhs because the function result has to be
8666 seen_array_ref
= false;
8667 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8669 if (ref
->type
== REF_ARRAY
)
8670 seen_array_ref
= true;
8671 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8675 /* Check for a dependency. */
8676 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8677 expr2
->value
.function
.esym
,
8678 expr2
->value
.function
.actual
,
8682 /* If we have reached here with an intrinsic function, we do not
8683 need a temporary except in the particular case that reallocation
8684 on assignment is active and the lhs is allocatable and a target. */
8685 if (expr2
->value
.function
.isym
)
8686 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8688 /* If the LHS is a dummy, we need a temporary if it is not
8690 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8693 /* If the lhs has been host_associated, is in common, a pointer or is
8694 a target and the function is not using a RESULT variable, aliasing
8695 can occur and a temporary is needed. */
8696 if ((sym
->attr
.host_assoc
8697 || sym
->attr
.in_common
8698 || sym
->attr
.pointer
8699 || sym
->attr
.cray_pointee
8700 || sym
->attr
.target
)
8701 && expr2
->symtree
!= NULL
8702 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8705 /* A PURE function can unconditionally be called without a temporary. */
8706 if (expr2
->value
.function
.esym
!= NULL
8707 && expr2
->value
.function
.esym
->attr
.pure
)
8710 /* Implicit_pure functions are those which could legally be declared
8712 if (expr2
->value
.function
.esym
!= NULL
8713 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8716 if (!sym
->attr
.use_assoc
8717 && !sym
->attr
.in_common
8718 && !sym
->attr
.pointer
8719 && !sym
->attr
.target
8720 && !sym
->attr
.cray_pointee
8721 && expr2
->value
.function
.esym
)
8723 /* A temporary is not needed if the function is not contained and
8724 the variable is local or host associated and not a pointer or
8726 if (!expr2
->value
.function
.esym
->attr
.contained
)
8729 /* A temporary is not needed if the lhs has never been host
8730 associated and the procedure is contained. */
8731 else if (!sym
->attr
.host_assoc
)
8734 /* A temporary is not needed if the variable is local and not
8735 a pointer, a target or a result. */
8737 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8741 /* Default to temporary use. */
8746 /* Provide the loop info so that the lhs descriptor can be built for
8747 reallocatable assignments from extrinsic function calls. */
8750 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8753 /* Signal that the function call should not be made by
8754 gfc_conv_loop_setup. */
8755 se
->ss
->is_alloc_lhs
= 1;
8756 gfc_init_loopinfo (loop
);
8757 gfc_add_ss_to_loop (loop
, *ss
);
8758 gfc_add_ss_to_loop (loop
, se
->ss
);
8759 gfc_conv_ss_startstride (loop
);
8760 gfc_conv_loop_setup (loop
, where
);
8761 gfc_copy_loopinfo_to_se (se
, loop
);
8762 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8763 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8764 se
->ss
->is_alloc_lhs
= 0;
8768 /* For assignment to a reallocatable lhs from intrinsic functions,
8769 replace the se.expr (ie. the result) with a temporary descriptor.
8770 Null the data field so that the library allocates space for the
8771 result. Free the data of the original descriptor after the function,
8772 in case it appears in an argument expression and transfer the
8773 result to the original descriptor. */
8776 fcncall_realloc_result (gfc_se
*se
, int rank
)
8785 /* Use the allocation done by the library. Substitute the lhs
8786 descriptor with a copy, whose data field is nulled.*/
8787 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8788 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8789 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8791 /* Unallocated, the descriptor does not have a dtype. */
8792 tmp
= gfc_conv_descriptor_dtype (desc
);
8793 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8795 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8796 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8797 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8799 /* Free the lhs after the function call and copy the result data to
8800 the lhs descriptor. */
8801 tmp
= gfc_conv_descriptor_data_get (desc
);
8802 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8803 boolean_type_node
, tmp
,
8804 build_int_cst (TREE_TYPE (tmp
), 0));
8805 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8806 tmp
= gfc_call_free (tmp
);
8807 gfc_add_expr_to_block (&se
->post
, tmp
);
8809 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8810 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8812 /* Check that the shapes are the same between lhs and expression. */
8813 for (n
= 0 ; n
< rank
; n
++)
8816 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8817 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8818 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8819 gfc_array_index_type
, tmp
, tmp1
);
8820 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8821 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8822 gfc_array_index_type
, tmp
, tmp1
);
8823 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8824 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8825 gfc_array_index_type
, tmp
, tmp1
);
8826 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8827 boolean_type_node
, tmp
,
8828 gfc_index_zero_node
);
8829 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8830 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8831 boolean_type_node
, tmp
,
8835 /* 'zero_cond' being true is equal to lhs not being allocated or the
8836 shapes being different. */
8837 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8839 /* Now reset the bounds returned from the function call to bounds based
8840 on the lhs lbounds, except where the lhs is not allocated or the shapes
8841 of 'variable and 'expr' are different. Set the offset accordingly. */
8842 offset
= gfc_index_zero_node
;
8843 for (n
= 0 ; n
< rank
; n
++)
8847 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8848 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8849 gfc_array_index_type
, zero_cond
,
8850 gfc_index_one_node
, lbound
);
8851 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8853 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8854 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8855 gfc_array_index_type
, tmp
, lbound
);
8856 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8857 gfc_rank_cst
[n
], lbound
);
8858 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8859 gfc_rank_cst
[n
], tmp
);
8861 /* Set stride and accumulate the offset. */
8862 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8863 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8864 gfc_rank_cst
[n
], tmp
);
8865 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8866 gfc_array_index_type
, lbound
, tmp
);
8867 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8868 gfc_array_index_type
, offset
, tmp
);
8869 offset
= gfc_evaluate_now (offset
, &se
->post
);
8872 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8877 /* Try to translate array(:) = func (...), where func is a transformational
8878 array function, without using a temporary. Returns NULL if this isn't the
8882 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8886 gfc_component
*comp
= NULL
;
8889 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8892 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8894 comp
= gfc_get_proc_ptr_comp (expr2
);
8895 gcc_assert (expr2
->value
.function
.isym
8896 || (comp
&& comp
->attr
.dimension
)
8897 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8898 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8900 gfc_init_se (&se
, NULL
);
8901 gfc_start_block (&se
.pre
);
8902 se
.want_pointer
= 1;
8904 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8906 if (expr1
->ts
.type
== BT_DERIVED
8907 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8910 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8912 gfc_add_expr_to_block (&se
.pre
, tmp
);
8915 se
.direct_byref
= 1;
8916 se
.ss
= gfc_walk_expr (expr2
);
8917 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8919 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8920 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8921 Clearly, this cannot be done for an allocatable function result, since
8922 the shape of the result is unknown and, in any case, the function must
8923 correctly take care of the reallocation internally. For intrinsic
8924 calls, the array data is freed and the library takes care of allocation.
8925 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8927 if (flag_realloc_lhs
8928 && gfc_is_reallocatable_lhs (expr1
)
8929 && !gfc_expr_attr (expr1
).codimension
8930 && !gfc_is_coindexed (expr1
)
8931 && !(expr2
->value
.function
.esym
8932 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8934 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8936 if (!expr2
->value
.function
.isym
)
8938 ss
= gfc_walk_expr (expr1
);
8939 gcc_assert (ss
!= gfc_ss_terminator
);
8941 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8942 ss
->is_alloc_lhs
= 1;
8945 fcncall_realloc_result (&se
, expr1
->rank
);
8948 gfc_conv_function_expr (&se
, expr2
);
8949 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8952 gfc_cleanup_loop (&loop
);
8954 gfc_free_ss_chain (se
.ss
);
8956 return gfc_finish_block (&se
.pre
);
8960 /* Try to efficiently translate array(:) = 0. Return NULL if this
8964 gfc_trans_zero_assign (gfc_expr
* expr
)
8966 tree dest
, len
, type
;
8970 sym
= expr
->symtree
->n
.sym
;
8971 dest
= gfc_get_symbol_decl (sym
);
8973 type
= TREE_TYPE (dest
);
8974 if (POINTER_TYPE_P (type
))
8975 type
= TREE_TYPE (type
);
8976 if (!GFC_ARRAY_TYPE_P (type
))
8979 /* Determine the length of the array. */
8980 len
= GFC_TYPE_ARRAY_SIZE (type
);
8981 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8984 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8985 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8986 fold_convert (gfc_array_index_type
, tmp
));
8988 /* If we are zeroing a local array avoid taking its address by emitting
8990 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8991 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8992 dest
, build_constructor (TREE_TYPE (dest
),
8995 /* Convert arguments to the correct types. */
8996 dest
= fold_convert (pvoid_type_node
, dest
);
8997 len
= fold_convert (size_type_node
, len
);
8999 /* Construct call to __builtin_memset. */
9000 tmp
= build_call_expr_loc (input_location
,
9001 builtin_decl_explicit (BUILT_IN_MEMSET
),
9002 3, dest
, integer_zero_node
, len
);
9003 return fold_convert (void_type_node
, tmp
);
9007 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9008 that constructs the call to __builtin_memcpy. */
9011 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
9015 /* Convert arguments to the correct types. */
9016 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
9017 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
9019 dst
= fold_convert (pvoid_type_node
, dst
);
9021 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
9022 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
9024 src
= fold_convert (pvoid_type_node
, src
);
9026 len
= fold_convert (size_type_node
, len
);
9028 /* Construct call to __builtin_memcpy. */
9029 tmp
= build_call_expr_loc (input_location
,
9030 builtin_decl_explicit (BUILT_IN_MEMCPY
),
9032 return fold_convert (void_type_node
, tmp
);
9036 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9037 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9038 source/rhs, both are gfc_full_array_ref_p which have been checked for
9042 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9044 tree dst
, dlen
, dtype
;
9045 tree src
, slen
, stype
;
9048 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9049 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
9051 dtype
= TREE_TYPE (dst
);
9052 if (POINTER_TYPE_P (dtype
))
9053 dtype
= TREE_TYPE (dtype
);
9054 stype
= TREE_TYPE (src
);
9055 if (POINTER_TYPE_P (stype
))
9056 stype
= TREE_TYPE (stype
);
9058 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
9061 /* Determine the lengths of the arrays. */
9062 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
9063 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
9065 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9066 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9067 dlen
, fold_convert (gfc_array_index_type
, tmp
));
9069 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
9070 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
9072 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
9073 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
9074 slen
, fold_convert (gfc_array_index_type
, tmp
));
9076 /* Sanity check that they are the same. This should always be
9077 the case, as we should already have checked for conformance. */
9078 if (!tree_int_cst_equal (slen
, dlen
))
9081 return gfc_build_memcpy_call (dst
, src
, dlen
);
9085 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9086 this can't be done. EXPR1 is the destination/lhs for which
9087 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9090 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
9092 unsigned HOST_WIDE_INT nelem
;
9098 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
9102 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
9103 dtype
= TREE_TYPE (dst
);
9104 if (POINTER_TYPE_P (dtype
))
9105 dtype
= TREE_TYPE (dtype
);
9106 if (!GFC_ARRAY_TYPE_P (dtype
))
9109 /* Determine the lengths of the array. */
9110 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
9111 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
9114 /* Confirm that the constructor is the same size. */
9115 if (compare_tree_int (len
, nelem
) != 0)
9118 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
9119 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
9120 fold_convert (gfc_array_index_type
, tmp
));
9122 stype
= gfc_typenode_for_spec (&expr2
->ts
);
9123 src
= gfc_build_constant_array_constructor (expr2
, stype
);
9125 stype
= TREE_TYPE (src
);
9126 if (POINTER_TYPE_P (stype
))
9127 stype
= TREE_TYPE (stype
);
9129 return gfc_build_memcpy_call (dst
, src
, len
);
9133 /* Tells whether the expression is to be treated as a variable reference. */
9136 gfc_expr_is_variable (gfc_expr
*expr
)
9139 gfc_component
*comp
;
9140 gfc_symbol
*func_ifc
;
9142 if (expr
->expr_type
== EXPR_VARIABLE
)
9145 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
9148 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
9149 return gfc_expr_is_variable (arg
);
9152 /* A data-pointer-returning function should be considered as a variable
9154 if (expr
->expr_type
== EXPR_FUNCTION
9155 && expr
->ref
== NULL
)
9157 if (expr
->value
.function
.isym
!= NULL
)
9160 if (expr
->value
.function
.esym
!= NULL
)
9162 func_ifc
= expr
->value
.function
.esym
;
9167 gcc_assert (expr
->symtree
);
9168 func_ifc
= expr
->symtree
->n
.sym
;
9175 comp
= gfc_get_proc_ptr_comp (expr
);
9176 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
9179 func_ifc
= comp
->ts
.interface
;
9183 if (expr
->expr_type
== EXPR_COMPCALL
)
9185 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
9186 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
9193 gcc_assert (func_ifc
->attr
.function
9194 && func_ifc
->result
!= NULL
);
9195 return func_ifc
->result
->attr
.pointer
;
9199 /* Is the lhs OK for automatic reallocation? */
9202 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
9206 /* An allocatable variable with no reference. */
9207 if (expr
->symtree
->n
.sym
->attr
.allocatable
9211 /* All that can be left are allocatable components. However, we do
9212 not check for allocatable components here because the expression
9213 could be an allocatable component of a pointer component. */
9214 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
9215 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
9218 /* Find an allocatable component ref last. */
9219 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
9220 if (ref
->type
== REF_COMPONENT
9222 && ref
->u
.c
.component
->attr
.allocatable
)
9229 /* Allocate or reallocate scalar lhs, as necessary. */
9232 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
9247 if (!expr1
|| expr1
->rank
)
9250 if (!expr2
|| expr2
->rank
)
9253 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9254 if (ref
->type
== REF_SUBSTRING
)
9257 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9259 /* Since this is a scalar lhs, we can afford to do this. That is,
9260 there is no risk of side effects being repeated. */
9261 gfc_init_se (&lse
, NULL
);
9262 lse
.want_pointer
= 1;
9263 gfc_conv_expr (&lse
, expr1
);
9265 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9266 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9268 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9269 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9270 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9272 tmp
= build3_v (COND_EXPR
, cond
,
9273 build1_v (GOTO_EXPR
, jump_label1
),
9274 build_empty_stmt (input_location
));
9275 gfc_add_expr_to_block (block
, tmp
);
9277 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9279 /* Use the rhs string length and the lhs element size. */
9280 size
= string_length
;
9281 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9282 tmp
= TYPE_SIZE_UNIT (tmp
);
9283 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9284 TREE_TYPE (tmp
), tmp
,
9285 fold_convert (TREE_TYPE (tmp
), size
));
9289 /* Otherwise use the length in bytes of the rhs. */
9290 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9291 size_in_bytes
= size
;
9294 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9295 size_in_bytes
, size_one_node
);
9297 if (gfc_caf_attr (expr1
).codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
)
9299 tree caf_decl
, token
;
9301 symbol_attribute attr
;
9303 gfc_clear_attr (&attr
);
9304 gfc_init_se (&caf_se
, NULL
);
9306 caf_decl
= gfc_get_tree_for_caf_expr (expr1
);
9307 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
, NULL_TREE
,
9309 gfc_add_block_to_block (block
, &caf_se
.pre
);
9310 gfc_allocate_allocatable (block
, lse
.expr
, size_in_bytes
,
9311 gfc_build_addr_expr (NULL_TREE
, token
),
9312 NULL_TREE
, NULL_TREE
, NULL_TREE
, jump_label1
,
9315 else if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9317 tmp
= build_call_expr_loc (input_location
,
9318 builtin_decl_explicit (BUILT_IN_CALLOC
),
9319 2, build_one_cst (size_type_node
),
9321 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9322 gfc_add_modify (block
, lse
.expr
, tmp
);
9326 tmp
= build_call_expr_loc (input_location
,
9327 builtin_decl_explicit (BUILT_IN_MALLOC
),
9329 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9330 gfc_add_modify (block
, lse
.expr
, tmp
);
9333 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9335 /* Deferred characters need checking for lhs and rhs string
9336 length. Other deferred parameter variables will have to
9338 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9339 gfc_add_expr_to_block (block
, tmp
);
9341 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9342 gfc_add_expr_to_block (block
, tmp
);
9344 /* For a deferred length character, reallocate if lengths of lhs and
9345 rhs are different. */
9346 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9348 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9349 lse
.string_length
, size
);
9350 /* Jump past the realloc if the lengths are the same. */
9351 tmp
= build3_v (COND_EXPR
, cond
,
9352 build1_v (GOTO_EXPR
, jump_label2
),
9353 build_empty_stmt (input_location
));
9354 gfc_add_expr_to_block (block
, tmp
);
9355 tmp
= build_call_expr_loc (input_location
,
9356 builtin_decl_explicit (BUILT_IN_REALLOC
),
9357 2, fold_convert (pvoid_type_node
, lse
.expr
),
9359 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9360 gfc_add_modify (block
, lse
.expr
, tmp
);
9361 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9362 gfc_add_expr_to_block (block
, tmp
);
9364 /* Update the lhs character length. */
9365 size
= string_length
;
9366 gfc_add_modify (block
, lse
.string_length
, size
);
9370 /* Check for assignments of the type
9374 to make sure we do not check for reallocation unneccessarily. */
9378 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9380 gfc_actual_arglist
*a
;
9383 switch (expr2
->expr_type
)
9386 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9389 if (expr2
->value
.function
.esym
9390 && expr2
->value
.function
.esym
->attr
.elemental
)
9392 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9395 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9400 else if (expr2
->value
.function
.isym
9401 && expr2
->value
.function
.isym
->elemental
)
9403 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9406 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9415 switch (expr2
->value
.op
.op
)
9418 case INTRINSIC_UPLUS
:
9419 case INTRINSIC_UMINUS
:
9420 case INTRINSIC_PARENTHESES
:
9421 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9423 case INTRINSIC_PLUS
:
9424 case INTRINSIC_MINUS
:
9425 case INTRINSIC_TIMES
:
9426 case INTRINSIC_DIVIDE
:
9427 case INTRINSIC_POWER
:
9431 case INTRINSIC_NEQV
:
9438 case INTRINSIC_EQ_OS
:
9439 case INTRINSIC_NE_OS
:
9440 case INTRINSIC_GT_OS
:
9441 case INTRINSIC_GE_OS
:
9442 case INTRINSIC_LT_OS
:
9443 case INTRINSIC_LE_OS
:
9445 e1
= expr2
->value
.op
.op1
;
9446 e2
= expr2
->value
.op
.op2
;
9448 if (e1
->rank
== 0 && e2
->rank
> 0)
9449 return is_runtime_conformable (expr1
, e2
);
9450 else if (e1
->rank
> 0 && e2
->rank
== 0)
9451 return is_runtime_conformable (expr1
, e1
);
9452 else if (e1
->rank
> 0 && e2
->rank
> 0)
9453 return is_runtime_conformable (expr1
, e1
)
9454 && is_runtime_conformable (expr1
, e2
);
9472 trans_class_assignment (stmtblock_t
*block
, gfc_expr
*lhs
, gfc_expr
*rhs
,
9473 gfc_se
*lse
, gfc_se
*rse
, bool use_vptr_copy
)
9477 tree stdcopy
, to_len
, from_len
;
9478 vec
<tree
, va_gc
> *args
= NULL
;
9480 tmp
= trans_class_vptr_len_assignment (block
, lhs
, rhs
, rse
, &to_len
,
9483 fcn
= gfc_vptr_copy_get (tmp
);
9485 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (rse
->expr
))
9486 ? gfc_class_data_get (rse
->expr
) : rse
->expr
;
9489 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9490 || INDIRECT_REF_P (tmp
)
9491 || (rhs
->ts
.type
== BT_DERIVED
9492 && rhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9493 && !rhs
->ts
.u
.derived
->attr
.pointer
9494 && !rhs
->ts
.u
.derived
->attr
.allocatable
)
9495 || (UNLIMITED_POLY (rhs
)
9496 && !CLASS_DATA (rhs
)->attr
.pointer
9497 && !CLASS_DATA (rhs
)->attr
.allocatable
))
9498 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9500 vec_safe_push (args
, tmp
);
9501 tmp
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9502 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9503 if (!POINTER_TYPE_P (TREE_TYPE (tmp
))
9504 || INDIRECT_REF_P (tmp
)
9505 || (lhs
->ts
.type
== BT_DERIVED
9506 && lhs
->ts
.u
.derived
->attr
.unlimited_polymorphic
9507 && !lhs
->ts
.u
.derived
->attr
.pointer
9508 && !lhs
->ts
.u
.derived
->attr
.allocatable
)
9509 || (UNLIMITED_POLY (lhs
)
9510 && !CLASS_DATA (lhs
)->attr
.pointer
9511 && !CLASS_DATA (lhs
)->attr
.allocatable
))
9512 vec_safe_push (args
, gfc_build_addr_expr (NULL_TREE
, tmp
));
9514 vec_safe_push (args
, tmp
);
9516 stdcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9518 if (to_len
!= NULL_TREE
&& !integer_zerop (from_len
))
9521 vec_safe_push (args
, from_len
);
9522 vec_safe_push (args
, to_len
);
9523 extcopy
= build_call_vec (TREE_TYPE (TREE_TYPE (fcn
)), fcn
, args
);
9525 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
9526 boolean_type_node
, from_len
,
9528 return fold_build3_loc (input_location
, COND_EXPR
,
9529 void_type_node
, tmp
,
9537 tree rhst
= GFC_CLASS_TYPE_P (TREE_TYPE (lse
->expr
))
9538 ? gfc_class_data_get (lse
->expr
) : lse
->expr
;
9540 gfc_init_block (&tblock
);
9541 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
9542 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9543 if (!POINTER_TYPE_P (TREE_TYPE (rhst
)))
9544 rhst
= gfc_build_addr_expr (NULL_TREE
, rhst
);
9545 /* When coming from a ptr_copy lhs and rhs are swapped. */
9546 gfc_add_modify_loc (input_location
, &tblock
, rhst
,
9547 fold_convert (TREE_TYPE (rhst
), tmp
));
9548 return gfc_finish_block (&tblock
);
9552 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9553 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9554 init_flag indicates initialization expressions and dealloc that no
9555 deallocate prior assignment is needed (if in doubt, set true).
9556 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
9557 routine instead of a pointer assignment. Alias resolution is only done,
9558 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
9559 where it is known, that newly allocated memory on the lhs can never be
9560 an alias of the rhs. */
9563 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9564 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9569 gfc_ss
*lss_section
;
9576 bool scalar_to_array
;
9579 bool maybe_workshare
= false;
9580 symbol_attribute lhs_caf_attr
, rhs_caf_attr
, lhs_attr
;
9582 /* Assignment of the form lhs = rhs. */
9583 gfc_start_block (&block
);
9585 gfc_init_se (&lse
, NULL
);
9586 gfc_init_se (&rse
, NULL
);
9589 lss
= gfc_walk_expr (expr1
);
9590 if (gfc_is_reallocatable_lhs (expr1
)
9591 && !(expr2
->expr_type
== EXPR_FUNCTION
9592 && expr2
->value
.function
.isym
!= NULL
))
9593 lss
->is_alloc_lhs
= 1;
9596 if ((expr1
->ts
.type
== BT_DERIVED
)
9597 && (gfc_is_alloc_class_array_function (expr2
)
9598 || gfc_is_alloc_class_scalar_function (expr2
)))
9599 expr2
->must_finalize
= 1;
9601 /* Only analyze the expressions for coarray properties, when in coarray-lib
9603 if (flag_coarray
== GFC_FCOARRAY_LIB
)
9605 lhs_caf_attr
= gfc_caf_attr (expr1
);
9606 rhs_caf_attr
= gfc_caf_attr (expr2
);
9609 if (lss
!= gfc_ss_terminator
)
9611 /* The assignment needs scalarization. */
9614 /* Find a non-scalar SS from the lhs. */
9615 while (lss_section
!= gfc_ss_terminator
9616 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9617 lss_section
= lss_section
->next
;
9619 gcc_assert (lss_section
!= gfc_ss_terminator
);
9621 /* Initialize the scalarizer. */
9622 gfc_init_loopinfo (&loop
);
9625 rss
= gfc_walk_expr (expr2
);
9626 if (rss
== gfc_ss_terminator
)
9627 /* The rhs is scalar. Add a ss for the expression. */
9628 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9630 /* Associate the SS with the loop. */
9631 gfc_add_ss_to_loop (&loop
, lss
);
9632 gfc_add_ss_to_loop (&loop
, rss
);
9634 /* Calculate the bounds of the scalarization. */
9635 gfc_conv_ss_startstride (&loop
);
9636 /* Enable loop reversal. */
9637 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9638 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9639 /* Resolve any data dependencies in the statement. */
9641 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9642 /* Setup the scalarizing loops. */
9643 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9645 /* Setup the gfc_se structures. */
9646 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9647 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9650 gfc_mark_ss_chain_used (rss
, 1);
9651 if (loop
.temp_ss
== NULL
)
9654 gfc_mark_ss_chain_used (lss
, 1);
9658 lse
.ss
= loop
.temp_ss
;
9659 gfc_mark_ss_chain_used (lss
, 3);
9660 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9663 /* Allow the scalarizer to workshare array assignments. */
9664 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
9665 == OMPWS_WORKSHARE_FLAG
9666 && loop
.temp_ss
== NULL
)
9668 maybe_workshare
= true;
9669 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
9672 /* Start the scalarized loop body. */
9673 gfc_start_scalarized_body (&loop
, &body
);
9676 gfc_init_block (&body
);
9678 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9680 /* Translate the expression. */
9681 gfc_conv_expr (&rse
, expr2
);
9683 /* Deal with the case of a scalar class function assigned to a derived type. */
9684 if (gfc_is_alloc_class_scalar_function (expr2
)
9685 && expr1
->ts
.type
== BT_DERIVED
)
9687 rse
.expr
= gfc_class_data_get (rse
.expr
);
9688 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9691 /* Stabilize a string length for temporaries. */
9692 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
9693 && !(VAR_P (rse
.string_length
)
9694 || TREE_CODE (rse
.string_length
) == PARM_DECL
9695 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
9696 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9697 else if (expr2
->ts
.type
== BT_CHARACTER
)
9698 string_length
= rse
.string_length
;
9700 string_length
= NULL_TREE
;
9704 gfc_conv_tmp_array_ref (&lse
);
9705 if (expr2
->ts
.type
== BT_CHARACTER
)
9706 lse
.string_length
= string_length
;
9710 gfc_conv_expr (&lse
, expr1
);
9711 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
9713 && gfc_expr_attr (expr1
).allocatable
9720 /* We should only get array references here. */
9721 gcc_assert (TREE_CODE (lse
.expr
) == POINTER_PLUS_EXPR
9722 || TREE_CODE (lse
.expr
) == ARRAY_REF
);
9724 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
9725 or the array itself(ARRAY_REF). */
9726 tmp
= TREE_OPERAND (lse
.expr
, 0);
9728 /* Provide the address of the array. */
9729 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
9730 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9732 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9733 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9734 msg
= _("Assignment of scalar to unallocated array");
9735 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
9736 &expr1
->where
, msg
);
9740 /* Assignments of scalar derived types with allocatable components
9741 to arrays must be done with a deep copy and the rhs temporary
9742 must have its components deallocated afterwards. */
9743 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9744 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9745 && !gfc_expr_is_variable (expr2
)
9746 && expr1
->rank
&& !expr2
->rank
);
9747 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9749 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9750 && gfc_is_alloc_class_scalar_function (expr2
));
9751 if (scalar_to_array
&& dealloc
)
9753 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9754 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9757 /* When assigning a character function result to a deferred-length variable,
9758 the function call must happen before the (re)allocation of the lhs -
9759 otherwise the character length of the result is not known.
9760 NOTE: This relies on having the exact dependence of the length type
9761 parameter available to the caller; gfortran saves it in the .mod files.
9762 NOTE ALSO: The concatenation operation generates a temporary pointer,
9763 whose allocation must go to the innermost loop. */
9764 if (flag_realloc_lhs
9765 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
9766 && !(lss
!= gfc_ss_terminator
9767 && expr2
->expr_type
== EXPR_OP
9768 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))
9769 gfc_add_block_to_block (&block
, &rse
.pre
);
9771 /* Nullify the allocatable components corresponding to those of the lhs
9772 derived type, so that the finalization of the function result does not
9773 affect the lhs of the assignment. Prepend is used to ensure that the
9774 nullification occurs before the call to the finalizer. In the case of
9775 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9776 as part of the deep copy. */
9777 if (!scalar_to_array
&& expr1
->ts
.type
== BT_DERIVED
9778 && (gfc_is_alloc_class_array_function (expr2
)
9779 || gfc_is_alloc_class_scalar_function (expr2
)))
9782 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9783 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9784 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9785 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9788 lhs_attr
= gfc_expr_attr (expr1
);
9789 if ((use_vptr_copy
|| lhs_attr
.pointer
9790 || (lhs_attr
.allocatable
&& !lhs_attr
.dimension
))
9791 && (expr1
->ts
.type
== BT_CLASS
9792 || (gfc_is_class_array_ref (expr1
, NULL
)
9793 || gfc_is_class_scalar_expr (expr1
))
9794 || (gfc_is_class_array_ref (expr2
, NULL
)
9795 || gfc_is_class_scalar_expr (expr2
))))
9797 tmp
= trans_class_assignment (&body
, expr1
, expr2
, &lse
, &rse
,
9798 use_vptr_copy
|| (lhs_attr
.allocatable
9799 && !lhs_attr
.dimension
));
9800 /* Modify the expr1 after the assignment, to allow the realloc below.
9801 Therefore only needed, when realloc_lhs is enabled. */
9802 if (flag_realloc_lhs
&& !lhs_attr
.pointer
)
9803 gfc_add_data_component (expr1
);
9805 else if (flag_coarray
== GFC_FCOARRAY_LIB
9806 && lhs_caf_attr
.codimension
&& rhs_caf_attr
.codimension
9807 && lhs_caf_attr
.alloc_comp
&& rhs_caf_attr
.alloc_comp
)
9810 gfc_actual_arglist a1
, a2
;
9815 code
.ext
.actual
= &a1
;
9816 code
.resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9817 tmp
= gfc_conv_intrinsic_subroutine (&code
);
9820 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9821 gfc_expr_is_variable (expr2
)
9823 || expr2
->expr_type
== EXPR_ARRAY
,
9824 !(l_is_temp
|| init_flag
) && dealloc
);
9825 /* Add the pre blocks to the body. */
9826 gfc_add_block_to_block (&body
, &rse
.pre
);
9827 gfc_add_block_to_block (&body
, &lse
.pre
);
9828 gfc_add_expr_to_block (&body
, tmp
);
9829 /* Add the post blocks to the body. */
9830 gfc_add_block_to_block (&body
, &rse
.post
);
9831 gfc_add_block_to_block (&body
, &lse
.post
);
9833 if (lss
== gfc_ss_terminator
)
9835 /* F2003: Add the code for reallocation on assignment. */
9836 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9837 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9840 /* Use the scalar assignment as is. */
9841 gfc_add_block_to_block (&block
, &body
);
9845 gcc_assert (lse
.ss
== gfc_ss_terminator
9846 && rse
.ss
== gfc_ss_terminator
);
9850 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9852 /* We need to copy the temporary to the actual lhs. */
9853 gfc_init_se (&lse
, NULL
);
9854 gfc_init_se (&rse
, NULL
);
9855 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9856 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9858 rse
.ss
= loop
.temp_ss
;
9861 gfc_conv_tmp_array_ref (&rse
);
9862 gfc_conv_expr (&lse
, expr1
);
9864 gcc_assert (lse
.ss
== gfc_ss_terminator
9865 && rse
.ss
== gfc_ss_terminator
);
9867 if (expr2
->ts
.type
== BT_CHARACTER
)
9868 rse
.string_length
= string_length
;
9870 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9872 gfc_add_expr_to_block (&body
, tmp
);
9875 /* F2003: Allocate or reallocate lhs of allocatable array. */
9876 if (flag_realloc_lhs
9877 && gfc_is_reallocatable_lhs (expr1
)
9879 && !is_runtime_conformable (expr1
, expr2
))
9881 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9882 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9883 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9884 if (tmp
!= NULL_TREE
)
9885 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9888 if (maybe_workshare
)
9889 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
9891 /* Generate the copying loops. */
9892 gfc_trans_scalarizing_loops (&loop
, &body
);
9894 /* Wrap the whole thing up. */
9895 gfc_add_block_to_block (&block
, &loop
.pre
);
9896 gfc_add_block_to_block (&block
, &loop
.post
);
9898 gfc_cleanup_loop (&loop
);
9901 return gfc_finish_block (&block
);
9905 /* Check whether EXPR is a copyable array. */
9908 copyable_array_p (gfc_expr
* expr
)
9910 if (expr
->expr_type
!= EXPR_VARIABLE
)
9913 /* First check it's an array. */
9914 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9917 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9920 /* Next check that it's of a simple enough type. */
9921 switch (expr
->ts
.type
)
9933 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9942 /* Translate an assignment. */
9945 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9946 bool dealloc
, bool use_vptr_copy
, bool may_alias
)
9950 /* Special case a single function returning an array. */
9951 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9953 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9958 /* Special case assigning an array to zero. */
9959 if (copyable_array_p (expr1
)
9960 && is_zero_initializer_p (expr2
))
9962 tmp
= gfc_trans_zero_assign (expr1
);
9967 /* Special case copying one array to another. */
9968 if (copyable_array_p (expr1
)
9969 && copyable_array_p (expr2
)
9970 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9971 && !gfc_check_dependency (expr1
, expr2
, 0))
9973 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9978 /* Special case initializing an array from a constant array constructor. */
9979 if (copyable_array_p (expr1
)
9980 && expr2
->expr_type
== EXPR_ARRAY
9981 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9983 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9988 /* Fallback to the scalarizer to generate explicit loops. */
9989 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
,
9990 use_vptr_copy
, may_alias
);
9994 gfc_trans_init_assign (gfc_code
* code
)
9996 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
10000 gfc_trans_assign (gfc_code
* code
)
10002 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);