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 (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
76 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
77 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
78 gfc_get_dtype (type
));
79 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
81 /* Copy pointer address back - but only if it could have changed and
82 if the actual argument is a pointer and not, e.g., NULL(). */
83 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
84 gfc_add_modify (&se
->post
, scalar
,
85 fold_convert (TREE_TYPE (scalar
),
86 gfc_conv_descriptor_data_get (desc
)));
91 /* This is the seed for an eventual trans-class.c
93 The following parameters should not be used directly since they might
94 in future implementations. Use the corresponding APIs. */
95 #define CLASS_DATA_FIELD 0
96 #define CLASS_VPTR_FIELD 1
97 #define CLASS_LEN_FIELD 2
98 #define VTABLE_HASH_FIELD 0
99 #define VTABLE_SIZE_FIELD 1
100 #define VTABLE_EXTENDS_FIELD 2
101 #define VTABLE_DEF_INIT_FIELD 3
102 #define VTABLE_COPY_FIELD 4
103 #define VTABLE_FINAL_FIELD 5
107 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
111 vec
<constructor_elt
, va_gc
> *init
= NULL
;
113 field
= TYPE_FIELDS (TREE_TYPE (decl
));
114 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
115 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
117 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
118 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
120 return build_constructor (TREE_TYPE (decl
), init
);
125 gfc_class_data_get (tree decl
)
128 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
129 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
130 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
132 return fold_build3_loc (input_location
, COMPONENT_REF
,
133 TREE_TYPE (data
), decl
, data
,
139 gfc_class_vptr_get (tree decl
)
142 /* For class arrays decl may be a temporary descriptor handle, the vptr is
143 then available through the saved descriptor. */
144 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
145 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
146 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
147 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
148 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
149 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
151 return fold_build3_loc (input_location
, COMPONENT_REF
,
152 TREE_TYPE (vptr
), decl
, vptr
,
158 gfc_class_len_get (tree decl
)
161 /* For class arrays decl may be a temporary descriptor handle, the len is
162 then available through the saved descriptor. */
163 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
164 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
165 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
166 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
167 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
168 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
170 return fold_build3_loc (input_location
, COMPONENT_REF
,
171 TREE_TYPE (len
), decl
, len
,
176 /* Try to get the _len component of a class. When the class is not unlimited
177 poly, i.e. no _len field exists, then return a zero node. */
180 gfc_class_len_or_zero_get (tree decl
)
183 /* For class arrays decl may be a temporary descriptor handle, the vptr is
184 then available through the saved descriptor. */
185 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
186 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
187 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
188 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
189 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
190 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
192 return len
!= NULL_TREE
? fold_build3_loc (input_location
, COMPONENT_REF
,
193 TREE_TYPE (len
), decl
, len
,
199 /* Get the specified FIELD from the VPTR. */
202 vptr_field_get (tree vptr
, int fieldno
)
205 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
206 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
208 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
209 TREE_TYPE (field
), vptr
, field
,
216 /* Get the field from the class' vptr. */
219 class_vtab_field_get (tree decl
, int fieldno
)
222 vptr
= gfc_class_vptr_get (decl
);
223 return vptr_field_get (vptr
, fieldno
);
227 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
229 #define VTAB_GET_FIELD_GEN(name, field) tree \
230 gfc_class_vtab_## name ##_get (tree cl) \
232 return class_vtab_field_get (cl, field); \
236 gfc_vptr_## name ##_get (tree vptr) \
238 return vptr_field_get (vptr, field); \
241 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
242 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
243 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
244 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
245 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
248 /* The size field is returned as an array index type. Therefore treat
249 it and only it specially. */
252 gfc_class_vtab_size_get (tree cl
)
255 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
256 /* Always return size as an array index type. */
257 size
= fold_convert (gfc_array_index_type
, size
);
263 gfc_vptr_size_get (tree vptr
)
266 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
267 /* Always return size as an array index type. */
268 size
= fold_convert (gfc_array_index_type
, size
);
274 #undef CLASS_DATA_FIELD
275 #undef CLASS_VPTR_FIELD
276 #undef CLASS_LEN_FIELD
277 #undef VTABLE_HASH_FIELD
278 #undef VTABLE_SIZE_FIELD
279 #undef VTABLE_EXTENDS_FIELD
280 #undef VTABLE_DEF_INIT_FIELD
281 #undef VTABLE_COPY_FIELD
282 #undef VTABLE_FINAL_FIELD
285 /* Search for the last _class ref in the chain of references of this
286 expression and cut the chain there. Albeit this routine is similiar
287 to class.c::gfc_add_component_ref (), is there a significant
288 difference: gfc_add_component_ref () concentrates on an array ref to
289 be the last ref in the chain. This routine is oblivious to the kind
290 of refs following. */
293 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
296 gfc_ref
*ref
, *class_ref
, *tail
, *array_ref
;
298 /* Find the last class reference. */
301 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
303 if (ref
->type
== REF_ARRAY
304 && ref
->u
.ar
.type
!= AR_ELEMENT
)
307 if (ref
->type
== REF_COMPONENT
308 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
310 /* Component to the right of a part reference with nonzero rank
311 must not have the ALLOCATABLE attribute. If attempts are
312 made to reference such a component reference, an error results
313 followed by anICE. */
315 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
320 if (ref
->next
== NULL
)
324 /* Remove and store all subsequent references after the
328 tail
= class_ref
->next
;
329 class_ref
->next
= NULL
;
337 base_expr
= gfc_expr_to_initialize (e
);
339 /* Restore the original tail expression. */
342 gfc_free_ref_list (class_ref
->next
);
343 class_ref
->next
= tail
;
347 gfc_free_ref_list (e
->ref
);
354 /* Reset the vptr to the declared type, e.g. after deallocation. */
357 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
364 /* Evaluate the expression and obtain the vptr from it. */
365 gfc_init_se (&se
, NULL
);
367 gfc_conv_expr_descriptor (&se
, e
);
369 gfc_conv_expr (&se
, e
);
370 gfc_add_block_to_block (block
, &se
.pre
);
371 vptr
= gfc_get_vptr_from_expr (se
.expr
);
373 /* If a vptr is not found, we can do nothing more. */
374 if (vptr
== NULL_TREE
)
377 if (UNLIMITED_POLY (e
))
378 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
381 /* Return the vptr to the address of the declared type. */
382 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
383 vtable
= vtab
->backend_decl
;
384 if (vtable
== NULL_TREE
)
385 vtable
= gfc_get_symbol_decl (vtab
);
386 vtable
= gfc_build_addr_expr (NULL
, vtable
);
387 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
388 gfc_add_modify (block
, vptr
, vtable
);
393 /* Reset the len for unlimited polymorphic objects. */
396 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
400 e
= gfc_find_and_cut_at_last_class_ref (expr
);
403 gfc_add_len_component (e
);
404 gfc_init_se (&se_len
, NULL
);
405 gfc_conv_expr (&se_len
, e
);
406 gfc_add_modify (block
, se_len
.expr
,
407 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
412 /* Obtain the vptr of the last class reference in an expression.
413 Return NULL_TREE if no class reference is found. */
416 gfc_get_vptr_from_expr (tree expr
)
421 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
423 type
= TREE_TYPE (tmp
);
426 if (GFC_CLASS_TYPE_P (type
))
427 return gfc_class_vptr_get (tmp
);
428 if (type
!= TYPE_CANONICAL (type
))
429 type
= TYPE_CANONICAL (type
);
433 if (TREE_CODE (tmp
) == VAR_DECL
)
441 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
444 tree tmp
, tmp2
, type
;
446 gfc_conv_descriptor_data_set (block
, lhs_desc
,
447 gfc_conv_descriptor_data_get (rhs_desc
));
448 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
449 gfc_conv_descriptor_offset_get (rhs_desc
));
451 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
452 gfc_conv_descriptor_dtype (rhs_desc
));
454 /* Assign the dimension as range-ref. */
455 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
456 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
458 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
459 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
460 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
461 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
462 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
463 gfc_add_modify (block
, tmp
, tmp2
);
467 /* Takes a derived type expression and returns the address of a temporary
468 class object of the 'declared' type. If vptr is not NULL, this is
469 used for the temporary class object.
470 optional_alloc_ptr is false when the dummy is neither allocatable
471 nor a pointer; that's only relevant for the optional handling. */
473 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
474 gfc_typespec class_ts
, tree vptr
, bool optional
,
475 bool optional_alloc_ptr
)
478 tree cond_optional
= NULL_TREE
;
484 /* The derived type needs to be converted to a temporary
486 tmp
= gfc_typenode_for_spec (&class_ts
);
487 var
= gfc_create_var (tmp
, "class");
490 ctree
= gfc_class_vptr_get (var
);
492 if (vptr
!= NULL_TREE
)
494 /* Use the dynamic vptr. */
499 /* In this case the vtab corresponds to the derived type and the
500 vptr must point to it. */
501 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
503 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
505 gfc_add_modify (&parmse
->pre
, ctree
,
506 fold_convert (TREE_TYPE (ctree
), tmp
));
508 /* Now set the data field. */
509 ctree
= gfc_class_data_get (var
);
512 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
514 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
516 /* For an array reference in an elemental procedure call we need
517 to retain the ss to provide the scalarized array reference. */
518 gfc_conv_expr_reference (parmse
, e
);
519 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
521 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
523 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
524 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
529 ss
= gfc_walk_expr (e
);
530 if (ss
== gfc_ss_terminator
)
533 gfc_conv_expr_reference (parmse
, e
);
535 /* Scalar to an assumed-rank array. */
536 if (class_ts
.u
.derived
->components
->as
)
539 type
= get_scalar_to_descriptor_type (parmse
->expr
,
541 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
542 gfc_get_dtype (type
));
544 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
545 TREE_TYPE (parmse
->expr
),
546 cond_optional
, parmse
->expr
,
547 fold_convert (TREE_TYPE (parmse
->expr
),
549 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
553 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
555 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
557 fold_convert (TREE_TYPE (tmp
),
559 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
565 gfc_init_block (&block
);
568 gfc_conv_expr_descriptor (parmse
, e
);
570 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
572 gcc_assert (class_ts
.u
.derived
->components
->as
->type
574 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
578 if (gfc_expr_attr (e
).codimension
)
579 parmse
->expr
= fold_build1_loc (input_location
,
583 gfc_add_modify (&block
, ctree
, parmse
->expr
);
588 tmp
= gfc_finish_block (&block
);
590 gfc_init_block (&block
);
591 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
593 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
594 gfc_finish_block (&block
));
595 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
598 gfc_add_block_to_block (&parmse
->pre
, &block
);
602 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
603 && class_ts
.u
.derived
->components
->ts
.u
.derived
604 ->attr
.unlimited_polymorphic
)
606 /* Take care about initializing the _len component correctly. */
607 ctree
= gfc_class_len_get (var
);
608 if (UNLIMITED_POLY (e
))
613 len
= gfc_copy_expr (e
);
614 gfc_add_len_component (len
);
615 gfc_init_se (&se
, NULL
);
616 gfc_conv_expr (&se
, len
);
618 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
619 cond_optional
, se
.expr
,
620 fold_convert (TREE_TYPE (se
.expr
),
626 tmp
= integer_zero_node
;
627 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
630 /* Pass the address of the class object. */
631 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
633 if (optional
&& optional_alloc_ptr
)
634 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
635 TREE_TYPE (parmse
->expr
),
636 cond_optional
, parmse
->expr
,
637 fold_convert (TREE_TYPE (parmse
->expr
),
642 /* Create a new class container, which is required as scalar coarrays
643 have an array descriptor while normal scalars haven't. Optionally,
644 NULL pointer checks are added if the argument is OPTIONAL. */
647 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
648 gfc_typespec class_ts
, bool optional
)
650 tree var
, ctree
, tmp
;
655 gfc_init_block (&block
);
658 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
660 if (ref
->type
== REF_COMPONENT
661 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
665 if (class_ref
== NULL
666 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
667 tmp
= e
->symtree
->n
.sym
->backend_decl
;
670 /* Remove everything after the last class reference, convert the
671 expression and then recover its tailend once more. */
673 ref
= class_ref
->next
;
674 class_ref
->next
= NULL
;
675 gfc_init_se (&tmpse
, NULL
);
676 gfc_conv_expr (&tmpse
, e
);
677 class_ref
->next
= ref
;
681 var
= gfc_typenode_for_spec (&class_ts
);
682 var
= gfc_create_var (var
, "class");
684 ctree
= gfc_class_vptr_get (var
);
685 gfc_add_modify (&block
, ctree
,
686 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
688 ctree
= gfc_class_data_get (var
);
689 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
690 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
692 /* Pass the address of the class object. */
693 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
697 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
700 tmp
= gfc_finish_block (&block
);
702 gfc_init_block (&block
);
703 tmp2
= gfc_class_data_get (var
);
704 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
706 tmp2
= gfc_finish_block (&block
);
708 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
710 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
713 gfc_add_block_to_block (&parmse
->pre
, &block
);
717 /* Takes an intrinsic type expression and returns the address of a temporary
718 class object of the 'declared' type. */
720 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
721 gfc_typespec class_ts
)
729 /* The intrinsic type needs to be converted to a temporary
731 tmp
= gfc_typenode_for_spec (&class_ts
);
732 var
= gfc_create_var (tmp
, "class");
735 ctree
= gfc_class_vptr_get (var
);
737 vtab
= gfc_find_vtab (&e
->ts
);
739 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
740 gfc_add_modify (&parmse
->pre
, ctree
,
741 fold_convert (TREE_TYPE (ctree
), tmp
));
743 /* Now set the data field. */
744 ctree
= gfc_class_data_get (var
);
745 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
747 /* For an array reference in an elemental procedure call we need
748 to retain the ss to provide the scalarized array reference. */
749 gfc_conv_expr_reference (parmse
, e
);
750 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
751 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
755 ss
= gfc_walk_expr (e
);
756 if (ss
== gfc_ss_terminator
)
759 gfc_conv_expr_reference (parmse
, e
);
760 if (class_ts
.u
.derived
->components
->as
761 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
763 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
765 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
766 TREE_TYPE (ctree
), tmp
);
769 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
770 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
775 parmse
->use_offset
= 1;
776 gfc_conv_expr_descriptor (parmse
, e
);
777 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
779 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
780 TREE_TYPE (ctree
), parmse
->expr
);
781 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
784 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
788 gcc_assert (class_ts
.type
== BT_CLASS
);
789 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
790 && class_ts
.u
.derived
->components
->ts
.u
.derived
791 ->attr
.unlimited_polymorphic
)
793 ctree
= gfc_class_len_get (var
);
794 /* When the actual arg is a char array, then set the _len component of the
795 unlimited polymorphic entity, too. */
796 if (e
->ts
.type
== BT_CHARACTER
)
798 /* Start with parmse->string_length because this seems to be set to a
799 correct value more often. */
800 if (parmse
->string_length
)
801 tmp
= parmse
->string_length
;
802 /* When the string_length is not yet set, then try the backend_decl of
804 else if (e
->ts
.u
.cl
->backend_decl
)
805 tmp
= e
->ts
.u
.cl
->backend_decl
;
806 /* If both of the above approaches fail, then try to generate an
807 expression from the input, which is only feasible currently, when the
808 expression can be evaluated to a constant one. */
811 /* Try to simplify the expression. */
812 gfc_simplify_expr (e
, 0);
813 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
815 /* Amazingly all data is present to compute the length of a
816 constant string, but the expression is not yet there. */
817 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
819 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
820 e
->value
.character
.length
);
821 gfc_conv_const_charlen (e
->ts
.u
.cl
);
822 e
->ts
.u
.cl
->resolved
= 1;
823 tmp
= e
->ts
.u
.cl
->backend_decl
;
827 gfc_error ("Can't compute the length of the char array at %L.",
833 tmp
= integer_zero_node
;
835 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
837 else if (class_ts
.type
== BT_CLASS
838 && class_ts
.u
.derived
->components
839 && class_ts
.u
.derived
->components
->ts
.u
840 .derived
->attr
.unlimited_polymorphic
)
842 ctree
= gfc_class_len_get (var
);
843 gfc_add_modify (&parmse
->pre
, ctree
,
844 fold_convert (TREE_TYPE (ctree
),
847 /* Pass the address of the class object. */
848 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
852 /* Takes a scalarized class array expression and returns the
853 address of a temporary scalar class object of the 'declared'
855 OOP-TODO: This could be improved by adding code that branched on
856 the dynamic type being the same as the declared type. In this case
857 the original class expression can be passed directly.
858 optional_alloc_ptr is false when the dummy is neither allocatable
859 nor a pointer; that's relevant for the optional handling.
860 Set copyback to true if class container's _data and _vtab pointers
861 might get modified. */
864 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
865 bool elemental
, bool copyback
, bool optional
,
866 bool optional_alloc_ptr
)
872 tree cond
= NULL_TREE
;
873 tree slen
= NULL_TREE
;
877 bool full_array
= false;
879 gfc_init_block (&block
);
882 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
884 if (ref
->type
== REF_COMPONENT
885 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
888 if (ref
->next
== NULL
)
892 if ((ref
== NULL
|| class_ref
== ref
)
893 && (!class_ts
.u
.derived
->components
->as
894 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
897 /* Test for FULL_ARRAY. */
898 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
899 && gfc_expr_attr (e
).dimension
)
902 gfc_is_class_array_ref (e
, &full_array
);
904 /* The derived type needs to be converted to a temporary
906 tmp
= gfc_typenode_for_spec (&class_ts
);
907 var
= gfc_create_var (tmp
, "class");
910 ctree
= gfc_class_data_get (var
);
911 if (class_ts
.u
.derived
->components
->as
912 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
916 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
918 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
919 gfc_get_dtype (type
));
921 tmp
= gfc_class_data_get (parmse
->expr
);
922 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
923 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
925 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
928 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
932 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
933 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
934 TREE_TYPE (ctree
), parmse
->expr
);
935 gfc_add_modify (&block
, ctree
, parmse
->expr
);
938 /* Return the data component, except in the case of scalarized array
939 references, where nullification of the cannot occur and so there
941 if (!elemental
&& full_array
&& copyback
)
943 if (class_ts
.u
.derived
->components
->as
944 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
947 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
948 gfc_conv_descriptor_data_get (ctree
));
950 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
953 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
957 ctree
= gfc_class_vptr_get (var
);
959 /* The vptr is the second field of the actual argument.
960 First we have to find the corresponding class reference. */
963 if (class_ref
== NULL
964 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
966 tmp
= e
->symtree
->n
.sym
->backend_decl
;
967 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
968 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
969 slen
= integer_zero_node
;
973 /* Remove everything after the last class reference, convert the
974 expression and then recover its tailend once more. */
976 ref
= class_ref
->next
;
977 class_ref
->next
= NULL
;
978 gfc_init_se (&tmpse
, NULL
);
979 gfc_conv_expr (&tmpse
, e
);
980 class_ref
->next
= ref
;
982 slen
= tmpse
.string_length
;
985 gcc_assert (tmp
!= NULL_TREE
);
987 /* Dereference if needs be. */
988 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
989 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
991 vptr
= gfc_class_vptr_get (tmp
);
992 gfc_add_modify (&block
, ctree
,
993 fold_convert (TREE_TYPE (ctree
), vptr
));
995 /* Return the vptr component, except in the case of scalarized array
996 references, where the dynamic type cannot change. */
997 if (!elemental
&& full_array
&& copyback
)
998 gfc_add_modify (&parmse
->post
, vptr
,
999 fold_convert (TREE_TYPE (vptr
), ctree
));
1001 /* For unlimited polymorphic objects also set the _len component. */
1002 if (class_ts
.type
== BT_CLASS
1003 && class_ts
.u
.derived
->components
1004 && class_ts
.u
.derived
->components
->ts
.u
1005 .derived
->attr
.unlimited_polymorphic
)
1007 ctree
= gfc_class_len_get (var
);
1008 if (UNLIMITED_POLY (e
))
1009 tmp
= gfc_class_len_get (tmp
);
1010 else if (e
->ts
.type
== BT_CHARACTER
)
1012 gcc_assert (slen
!= NULL_TREE
);
1016 tmp
= integer_zero_node
;
1017 gfc_add_modify (&parmse
->pre
, ctree
,
1018 fold_convert (TREE_TYPE (ctree
), tmp
));
1025 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1026 /* parmse->pre may contain some preparatory instructions for the
1027 temporary array descriptor. Those may only be executed when the
1028 optional argument is set, therefore add parmse->pre's instructions
1029 to block, which is later guarded by an if (optional_arg_given). */
1030 gfc_add_block_to_block (&parmse
->pre
, &block
);
1031 block
.head
= parmse
->pre
.head
;
1032 parmse
->pre
.head
= NULL_TREE
;
1033 tmp
= gfc_finish_block (&block
);
1035 if (optional_alloc_ptr
)
1036 tmp2
= build_empty_stmt (input_location
);
1039 gfc_init_block (&block
);
1041 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1042 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1043 null_pointer_node
));
1044 tmp2
= gfc_finish_block (&block
);
1047 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1049 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1052 gfc_add_block_to_block (&parmse
->pre
, &block
);
1054 /* Pass the address of the class object. */
1055 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1057 if (optional
&& optional_alloc_ptr
)
1058 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1059 TREE_TYPE (parmse
->expr
),
1061 fold_convert (TREE_TYPE (parmse
->expr
),
1062 null_pointer_node
));
1066 /* Given a class array declaration and an index, returns the address
1067 of the referenced element. */
1070 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1072 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1073 gfc_class_data_get (class_decl
);
1074 tree size
= gfc_class_vtab_size_get (class_decl
);
1075 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1076 gfc_array_index_type
,
1079 data
= gfc_conv_descriptor_data_get (data
);
1080 ptr
= fold_convert (pvoid_type_node
, data
);
1081 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1082 return fold_convert (TREE_TYPE (data
), ptr
);
1086 /* Copies one class expression to another, assuming that if either
1087 'to' or 'from' are arrays they are packed. Should 'from' be
1088 NULL_TREE, the initialization expression for 'to' is used, assuming
1089 that the _vptr is set. */
1092 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1102 vec
<tree
, va_gc
> *args
;
1107 bool is_from_desc
= false, is_to_class
= false;
1110 /* To prevent warnings on uninitialized variables. */
1111 from_len
= to_len
= NULL_TREE
;
1113 if (from
!= NULL_TREE
)
1114 fcn
= gfc_class_vtab_copy_get (from
);
1116 fcn
= gfc_class_vtab_copy_get (to
);
1118 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1120 if (from
!= NULL_TREE
)
1122 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1126 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1130 /* Check that from is a class. When the class is part of a coarray,
1131 then from is a common pointer and is to be used as is. */
1132 tmp
= POINTER_TYPE_P (TREE_TYPE (from
))
1133 ? build_fold_indirect_ref (from
) : from
;
1135 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1136 || (DECL_P (tmp
) && GFC_DECL_CLASS (tmp
)))
1137 ? gfc_class_data_get (from
) : from
;
1138 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1142 from_data
= gfc_class_vtab_def_init_get (to
);
1146 if (from
!= NULL_TREE
&& unlimited
)
1147 from_len
= gfc_class_len_or_zero_get (from
);
1149 from_len
= integer_zero_node
;
1152 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1155 to_data
= gfc_class_data_get (to
);
1157 to_len
= gfc_class_len_get (to
);
1160 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1163 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1165 stmtblock_t loopbody
;
1170 gfc_init_block (&body
);
1171 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1172 gfc_array_index_type
, nelems
,
1173 gfc_index_one_node
);
1174 nelems
= gfc_evaluate_now (tmp
, &body
);
1175 index
= gfc_create_var (gfc_array_index_type
, "S");
1179 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1180 vec_safe_push (args
, from_ref
);
1183 vec_safe_push (args
, from_data
);
1186 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1189 tmp
= gfc_conv_array_data (to
);
1190 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1191 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1192 gfc_build_array_ref (tmp
, index
, to
));
1194 vec_safe_push (args
, to_ref
);
1196 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1198 /* Build the body of the loop. */
1199 gfc_init_block (&loopbody
);
1200 gfc_add_expr_to_block (&loopbody
, tmp
);
1202 /* Build the loop and return. */
1203 gfc_init_loopinfo (&loop
);
1205 loop
.from
[0] = gfc_index_zero_node
;
1206 loop
.loopvar
[0] = index
;
1207 loop
.to
[0] = nelems
;
1208 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1209 gfc_init_block (&ifbody
);
1210 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1211 stdcopy
= gfc_finish_block (&ifbody
);
1212 /* In initialization mode from_len is a constant zero. */
1213 if (unlimited
&& !integer_zerop (from_len
))
1215 vec_safe_push (args
, from_len
);
1216 vec_safe_push (args
, to_len
);
1217 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1218 /* Build the body of the loop. */
1219 gfc_init_block (&loopbody
);
1220 gfc_add_expr_to_block (&loopbody
, tmp
);
1222 /* Build the loop and return. */
1223 gfc_init_loopinfo (&loop
);
1225 loop
.from
[0] = gfc_index_zero_node
;
1226 loop
.loopvar
[0] = index
;
1227 loop
.to
[0] = nelems
;
1228 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1229 gfc_init_block (&ifbody
);
1230 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1231 extcopy
= gfc_finish_block (&ifbody
);
1233 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1234 boolean_type_node
, from_len
,
1236 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1237 void_type_node
, tmp
, extcopy
, stdcopy
);
1238 gfc_add_expr_to_block (&body
, tmp
);
1239 tmp
= gfc_finish_block (&body
);
1243 gfc_add_expr_to_block (&body
, stdcopy
);
1244 tmp
= gfc_finish_block (&body
);
1246 gfc_cleanup_loop (&loop
);
1250 gcc_assert (!is_from_desc
);
1251 vec_safe_push (args
, from_data
);
1252 vec_safe_push (args
, to_data
);
1253 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1255 /* In initialization mode from_len is a constant zero. */
1256 if (unlimited
&& !integer_zerop (from_len
))
1258 vec_safe_push (args
, from_len
);
1259 vec_safe_push (args
, to_len
);
1260 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1261 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1262 boolean_type_node
, from_len
,
1264 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1265 void_type_node
, tmp
, extcopy
, stdcopy
);
1271 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1272 if (from
== NULL_TREE
)
1275 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1277 from_data
, null_pointer_node
);
1278 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1279 void_type_node
, cond
,
1280 tmp
, build_empty_stmt (input_location
));
1288 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1290 gfc_actual_arglist
*actual
;
1295 actual
= gfc_get_actual_arglist ();
1296 actual
->expr
= gfc_copy_expr (rhs
);
1297 actual
->next
= gfc_get_actual_arglist ();
1298 actual
->next
->expr
= gfc_copy_expr (lhs
);
1299 ppc
= gfc_copy_expr (obj
);
1300 gfc_add_vptr_component (ppc
);
1301 gfc_add_component_ref (ppc
, "_copy");
1302 ppc_code
= gfc_get_code (EXEC_CALL
);
1303 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1304 /* Although '_copy' is set to be elemental in class.c, it is
1305 not staying that way. Find out why, sometime.... */
1306 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1307 ppc_code
->ext
.actual
= actual
;
1308 ppc_code
->expr1
= ppc
;
1309 /* Since '_copy' is elemental, the scalarizer will take care
1310 of arrays in gfc_trans_call. */
1311 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1312 gfc_free_statements (ppc_code
);
1314 if (UNLIMITED_POLY(obj
))
1316 /* Check if rhs is non-NULL. */
1318 gfc_init_se (&src
, NULL
);
1319 gfc_conv_expr (&src
, rhs
);
1320 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1321 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1322 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1323 null_pointer_node
));
1324 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1325 build_empty_stmt (input_location
));
1331 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1332 A MEMCPY is needed to copy the full data from the default initializer
1333 of the dynamic type. */
1336 gfc_trans_class_init_assign (gfc_code
*code
)
1340 gfc_se dst
,src
,memsz
;
1341 gfc_expr
*lhs
, *rhs
, *sz
;
1343 gfc_start_block (&block
);
1345 lhs
= gfc_copy_expr (code
->expr1
);
1346 gfc_add_data_component (lhs
);
1348 rhs
= gfc_copy_expr (code
->expr1
);
1349 gfc_add_vptr_component (rhs
);
1351 /* Make sure that the component backend_decls have been built, which
1352 will not have happened if the derived types concerned have not
1354 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1355 gfc_add_def_init_component (rhs
);
1356 /* The _def_init is always scalar. */
1359 if (code
->expr1
->ts
.type
== BT_CLASS
1360 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1361 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1364 sz
= gfc_copy_expr (code
->expr1
);
1365 gfc_add_vptr_component (sz
);
1366 gfc_add_size_component (sz
);
1368 gfc_init_se (&dst
, NULL
);
1369 gfc_init_se (&src
, NULL
);
1370 gfc_init_se (&memsz
, NULL
);
1371 gfc_conv_expr (&dst
, lhs
);
1372 gfc_conv_expr (&src
, rhs
);
1373 gfc_conv_expr (&memsz
, sz
);
1374 gfc_add_block_to_block (&block
, &src
.pre
);
1375 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1377 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1379 if (UNLIMITED_POLY(code
->expr1
))
1381 /* Check if _def_init is non-NULL. */
1382 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1383 boolean_type_node
, src
.expr
,
1384 fold_convert (TREE_TYPE (src
.expr
),
1385 null_pointer_node
));
1386 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1387 tmp
, build_empty_stmt (input_location
));
1391 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1392 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1394 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1395 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1397 build_empty_stmt (input_location
));
1400 gfc_add_expr_to_block (&block
, tmp
);
1402 return gfc_finish_block (&block
);
1406 /* Translate an assignment to a CLASS object
1407 (pointer or ordinary assignment). */
1410 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1418 gfc_start_block (&block
);
1421 while (ref
&& ref
->next
)
1424 /* Class valued proc_pointer assignments do not need any further
1426 if (ref
&& ref
->type
== REF_COMPONENT
1427 && ref
->u
.c
.component
->attr
.proc_pointer
1428 && expr2
->expr_type
== EXPR_VARIABLE
1429 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1430 && op
== EXEC_POINTER_ASSIGN
)
1433 if (expr2
->ts
.type
!= BT_CLASS
)
1435 /* Insert an additional assignment which sets the '_vptr' field. */
1436 gfc_symbol
*vtab
= NULL
;
1439 lhs
= gfc_copy_expr (expr1
);
1440 gfc_add_vptr_component (lhs
);
1442 if (UNLIMITED_POLY (expr1
)
1443 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1445 rhs
= gfc_get_null_expr (&expr2
->where
);
1449 if (expr2
->expr_type
== EXPR_NULL
)
1450 vtab
= gfc_find_vtab (&expr1
->ts
);
1452 vtab
= gfc_find_vtab (&expr2
->ts
);
1455 rhs
= gfc_get_expr ();
1456 rhs
->expr_type
= EXPR_VARIABLE
;
1457 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1461 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1462 gfc_add_expr_to_block (&block
, tmp
);
1464 gfc_free_expr (lhs
);
1465 gfc_free_expr (rhs
);
1467 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1469 /* F2003:C717 only sequence and bind-C types can come here. */
1470 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1471 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1472 gfc_add_data_component (expr2
);
1475 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1477 /* Insert an additional assignment which sets the '_vptr' field. */
1478 lhs
= gfc_copy_expr (expr1
);
1479 gfc_add_vptr_component (lhs
);
1481 rhs
= gfc_copy_expr (expr2
);
1482 gfc_add_vptr_component (rhs
);
1484 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1485 gfc_add_expr_to_block (&block
, tmp
);
1487 gfc_free_expr (lhs
);
1488 gfc_free_expr (rhs
);
1491 /* Do the actual CLASS assignment. */
1492 if (expr2
->ts
.type
== BT_CLASS
1493 && !CLASS_DATA (expr2
)->attr
.dimension
)
1495 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1496 || !CLASS_DATA (expr2
)->attr
.dimension
)
1497 gfc_add_data_component (expr1
);
1501 if (op
== EXEC_ASSIGN
)
1502 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1503 else if (op
== EXEC_POINTER_ASSIGN
)
1504 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1508 gfc_add_expr_to_block (&block
, tmp
);
1510 return gfc_finish_block (&block
);
1514 /* End of prototype trans-class.c */
1518 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1520 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1521 gfc_warning (OPT_Wrealloc_lhs
,
1522 "Code for reallocating the allocatable array at %L will "
1524 else if (warn_realloc_lhs_all
)
1525 gfc_warning (OPT_Wrealloc_lhs_all
,
1526 "Code for reallocating the allocatable variable at %L "
1527 "will be added", where
);
1531 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1534 /* Copy the scalarization loop variables. */
1537 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1540 dest
->loop
= src
->loop
;
1544 /* Initialize a simple expression holder.
1546 Care must be taken when multiple se are created with the same parent.
1547 The child se must be kept in sync. The easiest way is to delay creation
1548 of a child se until after after the previous se has been translated. */
1551 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1553 memset (se
, 0, sizeof (gfc_se
));
1554 gfc_init_block (&se
->pre
);
1555 gfc_init_block (&se
->post
);
1557 se
->parent
= parent
;
1560 gfc_copy_se_loopvars (se
, parent
);
1564 /* Advances to the next SS in the chain. Use this rather than setting
1565 se->ss = se->ss->next because all the parents needs to be kept in sync.
1569 gfc_advance_se_ss_chain (gfc_se
* se
)
1574 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1577 /* Walk down the parent chain. */
1580 /* Simple consistency check. */
1581 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1582 || p
->parent
->ss
->nested_ss
== p
->ss
);
1584 /* If we were in a nested loop, the next scalarized expression can be
1585 on the parent ss' next pointer. Thus we should not take the next
1586 pointer blindly, but rather go up one nest level as long as next
1587 is the end of chain. */
1589 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1599 /* Ensures the result of the expression as either a temporary variable
1600 or a constant so that it can be used repeatedly. */
1603 gfc_make_safe_expr (gfc_se
* se
)
1607 if (CONSTANT_CLASS_P (se
->expr
))
1610 /* We need a temporary for this result. */
1611 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1612 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1617 /* Return an expression which determines if a dummy parameter is present.
1618 Also used for arguments to procedures with multiple entry points. */
1621 gfc_conv_expr_present (gfc_symbol
* sym
)
1625 gcc_assert (sym
->attr
.dummy
);
1626 decl
= gfc_get_symbol_decl (sym
);
1628 /* Intrinsic scalars with VALUE attribute which are passed by value
1629 use a hidden argument to denote the present status. */
1630 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1631 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1632 && !sym
->attr
.dimension
)
1634 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1637 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1639 strcpy (&name
[1], sym
->name
);
1640 tree_name
= get_identifier (name
);
1642 /* Walk function argument list to find hidden arg. */
1643 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1644 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1645 if (DECL_NAME (cond
) == tree_name
)
1652 if (TREE_CODE (decl
) != PARM_DECL
)
1654 /* Array parameters use a temporary descriptor, we want the real
1656 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1657 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1658 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1661 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1662 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1664 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1665 as actual argument to denote absent dummies. For array descriptors,
1666 we thus also need to check the array descriptor. For BT_CLASS, it
1667 can also occur for scalars and F2003 due to type->class wrapping and
1668 class->class wrapping. Note further that BT_CLASS always uses an
1669 array descriptor for arrays, also for explicit-shape/assumed-size. */
1671 if (!sym
->attr
.allocatable
1672 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1673 || (sym
->ts
.type
== BT_CLASS
1674 && !CLASS_DATA (sym
)->attr
.allocatable
1675 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1676 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1677 || sym
->ts
.type
== BT_CLASS
))
1681 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1682 || sym
->as
->type
== AS_ASSUMED_RANK
1683 || sym
->attr
.codimension
))
1684 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1686 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1687 if (sym
->ts
.type
== BT_CLASS
)
1688 tmp
= gfc_class_data_get (tmp
);
1689 tmp
= gfc_conv_array_data (tmp
);
1691 else if (sym
->ts
.type
== BT_CLASS
)
1692 tmp
= gfc_class_data_get (decl
);
1696 if (tmp
!= NULL_TREE
)
1698 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1699 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1700 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1701 boolean_type_node
, cond
, tmp
);
1709 /* Converts a missing, dummy argument into a null or zero. */
1712 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1717 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1721 /* Create a temporary and convert it to the correct type. */
1722 tmp
= gfc_get_int_type (kind
);
1723 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1726 /* Test for a NULL value. */
1727 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1728 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1729 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1730 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1734 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1736 build_zero_cst (TREE_TYPE (se
->expr
)));
1737 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1741 if (ts
.type
== BT_CHARACTER
)
1743 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1744 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1745 present
, se
->string_length
, tmp
);
1746 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1747 se
->string_length
= tmp
;
1753 /* Get the character length of an expression, looking through gfc_refs
1757 gfc_get_expr_charlen (gfc_expr
*e
)
1762 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1763 && e
->ts
.type
== BT_CHARACTER
);
1765 length
= NULL
; /* To silence compiler warning. */
1767 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1770 gfc_init_se (&tmpse
, NULL
);
1771 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1772 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1776 /* First candidate: if the variable is of type CHARACTER, the
1777 expression's length could be the length of the character
1779 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1780 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1782 /* Look through the reference chain for component references. */
1783 for (r
= e
->ref
; r
; r
= r
->next
)
1788 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1789 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1797 /* We should never got substring references here. These will be
1798 broken down by the scalarizer. */
1804 gcc_assert (length
!= NULL
);
1809 /* Return for an expression the backend decl of the coarray. */
1812 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1816 gfc_ref
*ref
, *comp_ref
= NULL
;
1818 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1820 /* Not-implemented diagnostic. */
1821 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1822 if (ref
->type
== REF_COMPONENT
)
1825 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1826 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1827 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1828 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1829 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1830 && !ref
->u
.c
.component
->attr
.codimension
1831 && (ref
->u
.c
.component
->attr
.pointer
1832 || ref
->u
.c
.component
->attr
.allocatable
)))
1833 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1834 "component of the coindexed coarray at %L is not yet "
1835 "supported", &expr
->where
);
1838 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1839 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1840 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1841 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1843 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1844 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1845 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1846 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1847 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1848 "not yet supported", &expr
->where
);
1852 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1853 general not possible as the required stride multiplier might be not
1854 a multiple of c_sizeof(b). In case of noncoindexed access, the
1855 scalarizer often takes care of it - for coarrays, it always fails. */
1856 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1857 if (ref
->type
== REF_COMPONENT
1858 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1859 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1860 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1861 && ref
->u
.c
.component
->attr
.codimension
)))
1865 for ( ; ref
; ref
= ref
->next
)
1866 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1868 for ( ; ref
; ref
= ref
->next
)
1869 if (ref
->type
== REF_COMPONENT
)
1870 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1871 "with an array partref is not yet supported",
1875 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1876 gcc_assert (caf_decl
);
1877 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1878 caf_decl
= gfc_class_data_get (caf_decl
);
1879 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1882 /* The following code assumes that the coarray is a component reachable via
1883 only scalar components/variables; the Fortran standard guarantees this. */
1885 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1886 if (ref
->type
== REF_COMPONENT
)
1888 gfc_component
*comp
= ref
->u
.c
.component
;
1890 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1891 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1892 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1893 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1894 comp
->backend_decl
, NULL_TREE
);
1895 if (comp
->ts
.type
== BT_CLASS
)
1896 caf_decl
= gfc_class_data_get (caf_decl
);
1897 if (comp
->attr
.codimension
)
1903 gcc_assert (found
&& caf_decl
);
1908 /* Obtain the Coarray token - and optionally also the offset. */
1911 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1916 /* Coarray token. */
1917 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1919 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1920 == GFC_ARRAY_ALLOCATABLE
1921 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1922 *token
= gfc_conv_descriptor_token (caf_decl
);
1924 else if (DECL_LANG_SPECIFIC (caf_decl
)
1925 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1926 *token
= GFC_DECL_TOKEN (caf_decl
);
1929 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1930 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1931 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1937 /* Offset between the coarray base address and the address wanted. */
1938 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1939 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1940 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1941 *offset
= build_int_cst (gfc_array_index_type
, 0);
1942 else if (DECL_LANG_SPECIFIC (caf_decl
)
1943 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1944 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1945 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1946 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1948 *offset
= build_int_cst (gfc_array_index_type
, 0);
1950 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1951 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1953 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1954 tmp
= gfc_conv_descriptor_data_get (tmp
);
1956 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1957 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1960 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1964 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1965 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1967 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1968 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1971 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1975 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1976 fold_convert (gfc_array_index_type
, *offset
),
1977 fold_convert (gfc_array_index_type
, tmp
));
1981 /* Convert the coindex of a coarray into an image index; the result is
1982 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1983 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1986 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1989 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1993 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1994 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1996 gcc_assert (ref
!= NULL
);
1998 img_idx
= integer_zero_node
;
1999 extent
= integer_one_node
;
2000 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
2001 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2003 gfc_init_se (&se
, NULL
);
2004 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2005 gfc_add_block_to_block (block
, &se
.pre
);
2006 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
2007 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2008 integer_type_node
, se
.expr
,
2009 fold_convert(integer_type_node
, lbound
));
2010 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2012 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2014 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2016 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
2017 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
2018 tmp
= fold_convert (integer_type_node
, tmp
);
2019 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2020 integer_type_node
, extent
, tmp
);
2024 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
2026 gfc_init_se (&se
, NULL
);
2027 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
2028 gfc_add_block_to_block (block
, &se
.pre
);
2029 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2030 lbound
= fold_convert (integer_type_node
, lbound
);
2031 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2032 integer_type_node
, se
.expr
, lbound
);
2033 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2035 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2037 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2039 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2040 ubound
= fold_convert (integer_type_node
, ubound
);
2041 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2042 integer_type_node
, ubound
, lbound
);
2043 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2044 tmp
, integer_one_node
);
2045 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2046 integer_type_node
, extent
, tmp
);
2049 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2050 img_idx
, integer_one_node
);
2055 /* For each character array constructor subexpression without a ts.u.cl->length,
2056 replace it by its first element (if there aren't any elements, the length
2057 should already be set to zero). */
2060 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2062 gfc_actual_arglist
* arg
;
2068 switch (e
->expr_type
)
2072 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2073 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2077 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2081 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2082 flatten_array_ctors_without_strlen (arg
->expr
);
2087 /* We've found what we're looking for. */
2088 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2093 gcc_assert (e
->value
.constructor
);
2095 c
= gfc_constructor_first (e
->value
.constructor
);
2099 flatten_array_ctors_without_strlen (new_expr
);
2100 gfc_replace_expr (e
, new_expr
);
2104 /* Otherwise, fall through to handle constructor elements. */
2105 case EXPR_STRUCTURE
:
2106 for (c
= gfc_constructor_first (e
->value
.constructor
);
2107 c
; c
= gfc_constructor_next (c
))
2108 flatten_array_ctors_without_strlen (c
->expr
);
2118 /* Generate code to initialize a string length variable. Returns the
2119 value. For array constructors, cl->length might be NULL and in this case,
2120 the first element of the constructor is needed. expr is the original
2121 expression so we can access it but can be NULL if this is not needed. */
2124 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2128 gfc_init_se (&se
, NULL
);
2132 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2135 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2136 "flatten" array constructors by taking their first element; all elements
2137 should be the same length or a cl->length should be present. */
2140 gfc_expr
* expr_flat
;
2142 expr_flat
= gfc_copy_expr (expr
);
2143 flatten_array_ctors_without_strlen (expr_flat
);
2144 gfc_resolve_expr (expr_flat
);
2146 gfc_conv_expr (&se
, expr_flat
);
2147 gfc_add_block_to_block (pblock
, &se
.pre
);
2148 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2150 gfc_free_expr (expr_flat
);
2154 /* Convert cl->length. */
2156 gcc_assert (cl
->length
);
2158 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2159 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2160 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2161 gfc_add_block_to_block (pblock
, &se
.pre
);
2163 if (cl
->backend_decl
)
2164 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2166 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2171 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2172 const char *name
, locus
*where
)
2182 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2183 type
= build_pointer_type (type
);
2185 gfc_init_se (&start
, se
);
2186 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2187 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2189 if (integer_onep (start
.expr
))
2190 gfc_conv_string_parameter (se
);
2195 /* Avoid multiple evaluation of substring start. */
2196 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2197 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2199 /* Change the start of the string. */
2200 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2203 tmp
= build_fold_indirect_ref_loc (input_location
,
2205 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2206 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2209 /* Length = end + 1 - start. */
2210 gfc_init_se (&end
, se
);
2211 if (ref
->u
.ss
.end
== NULL
)
2212 end
.expr
= se
->string_length
;
2215 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2216 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2220 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2221 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2223 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2225 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2226 boolean_type_node
, start
.expr
,
2229 /* Check lower bound. */
2230 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2232 build_int_cst (gfc_charlen_type_node
, 1));
2233 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2234 boolean_type_node
, nonempty
, fault
);
2236 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2237 "is less than one", name
);
2239 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2240 "is less than one");
2241 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2242 fold_convert (long_integer_type_node
,
2246 /* Check upper bound. */
2247 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2248 end
.expr
, se
->string_length
);
2249 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2250 boolean_type_node
, nonempty
, fault
);
2252 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2253 "exceeds string length (%%ld)", name
);
2255 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2256 "exceeds string length (%%ld)");
2257 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2258 fold_convert (long_integer_type_node
, end
.expr
),
2259 fold_convert (long_integer_type_node
,
2260 se
->string_length
));
2264 /* Try to calculate the length from the start and end expressions. */
2266 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2270 i_len
= mpz_get_si (length
) + 1;
2274 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2275 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2279 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2280 end
.expr
, start
.expr
);
2281 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2282 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2283 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2284 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2287 se
->string_length
= tmp
;
2291 /* Convert a derived type component reference. */
2294 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2302 c
= ref
->u
.c
.component
;
2304 if (c
->backend_decl
== NULL_TREE
2305 && ref
->u
.c
.sym
!= NULL
)
2306 gfc_get_derived_type (ref
->u
.c
.sym
);
2308 field
= c
->backend_decl
;
2309 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2311 context
= DECL_FIELD_CONTEXT (field
);
2313 /* Components can correspond to fields of different containing
2314 types, as components are created without context, whereas
2315 a concrete use of a component has the type of decl as context.
2316 So, if the type doesn't match, we search the corresponding
2317 FIELD_DECL in the parent type. To not waste too much time
2318 we cache this result in norestrict_decl.
2319 On the other hand, if the context is a UNION or a MAP (a
2320 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2322 if (context
!= TREE_TYPE (decl
)
2323 && !( TREE_CODE (TREE_TYPE (field
)) == UNION_TYPE
/* Field is union */
2324 || TREE_CODE (context
) == UNION_TYPE
)) /* Field is map */
2326 tree f2
= c
->norestrict_decl
;
2327 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2328 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2329 if (TREE_CODE (f2
) == FIELD_DECL
2330 && DECL_NAME (f2
) == DECL_NAME (field
))
2333 c
->norestrict_decl
= f2
;
2337 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2338 && strcmp ("_data", c
->name
) == 0)
2340 /* Found a ref to the _data component. Store the associated ref to
2341 the vptr in se->class_vptr. */
2342 se
->class_vptr
= gfc_class_vptr_get (decl
);
2345 se
->class_vptr
= NULL_TREE
;
2347 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2348 decl
, field
, NULL_TREE
);
2352 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2353 strlen () conditional below. */
2354 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2355 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2357 tmp
= c
->ts
.u
.cl
->backend_decl
;
2358 /* Components must always be constant length. */
2359 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2360 se
->string_length
= tmp
;
2363 if (gfc_deferred_strlen (c
, &field
))
2365 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2367 decl
, field
, NULL_TREE
);
2368 se
->string_length
= tmp
;
2371 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2372 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2373 && c
->ts
.type
!= BT_CHARACTER
)
2374 || c
->attr
.proc_pointer
)
2375 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2380 /* This function deals with component references to components of the
2381 parent type for derived type extensions. */
2383 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2391 c
= ref
->u
.c
.component
;
2393 /* Return if the component is in the parent type. */
2394 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2395 if (strcmp (c
->name
, cmp
->name
) == 0)
2398 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2399 parent
.type
= REF_COMPONENT
;
2401 parent
.u
.c
.sym
= dt
;
2402 parent
.u
.c
.component
= dt
->components
;
2404 if (dt
->backend_decl
== NULL
)
2405 gfc_get_derived_type (dt
);
2407 /* Build the reference and call self. */
2408 gfc_conv_component_ref (se
, &parent
);
2409 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2410 parent
.u
.c
.component
= c
;
2411 conv_parent_component_references (se
, &parent
);
2414 /* Return the contents of a variable. Also handles reference/pointer
2415 variables (all Fortran pointer references are implicit). */
2418 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2423 tree parent_decl
= NULL_TREE
;
2426 bool alternate_entry
;
2429 bool first_time
= true;
2431 sym
= expr
->symtree
->n
.sym
;
2432 is_classarray
= IS_CLASS_ARRAY (sym
);
2436 gfc_ss_info
*ss_info
= ss
->info
;
2438 /* Check that something hasn't gone horribly wrong. */
2439 gcc_assert (ss
!= gfc_ss_terminator
);
2440 gcc_assert (ss_info
->expr
== expr
);
2442 /* A scalarized term. We already know the descriptor. */
2443 se
->expr
= ss_info
->data
.array
.descriptor
;
2444 se
->string_length
= ss_info
->string_length
;
2445 ref
= ss_info
->data
.array
.ref
;
2447 gcc_assert (ref
->type
== REF_ARRAY
2448 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2450 gfc_conv_tmp_array_ref (se
);
2454 tree se_expr
= NULL_TREE
;
2456 se
->expr
= gfc_get_symbol_decl (sym
);
2458 /* Deal with references to a parent results or entries by storing
2459 the current_function_decl and moving to the parent_decl. */
2460 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2461 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2462 && sym
->result
== sym
;
2463 entry_master
= sym
->attr
.result
2464 && sym
->ns
->proc_name
->attr
.entry_master
2465 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2466 if (current_function_decl
)
2467 parent_decl
= DECL_CONTEXT (current_function_decl
);
2469 if ((se
->expr
== parent_decl
&& return_value
)
2470 || (sym
->ns
&& sym
->ns
->proc_name
2472 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2473 && (alternate_entry
|| entry_master
)))
2478 /* Special case for assigning the return value of a function.
2479 Self recursive functions must have an explicit return value. */
2480 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2481 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2483 /* Similarly for alternate entry points. */
2484 else if (alternate_entry
2485 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2488 gfc_entry_list
*el
= NULL
;
2490 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2493 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2498 else if (entry_master
2499 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2501 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2506 /* Procedure actual arguments. */
2507 else if (sym
->attr
.flavor
== FL_PROCEDURE
2508 && se
->expr
!= current_function_decl
)
2510 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2512 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2513 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2519 /* Dereference the expression, where needed. Since characters
2520 are entirely different from other types, they are treated
2522 if (sym
->ts
.type
== BT_CHARACTER
)
2524 /* Dereference character pointer dummy arguments
2526 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2528 || sym
->attr
.function
2529 || sym
->attr
.result
))
2530 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2534 else if (!sym
->attr
.value
)
2536 /* Dereference temporaries for class array dummy arguments. */
2537 if (sym
->attr
.dummy
&& is_classarray
2538 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2540 if (!se
->descriptor_only
)
2541 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2543 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2547 /* Dereference non-character scalar dummy arguments. */
2548 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2549 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2550 && (sym
->ts
.type
!= BT_CLASS
2551 || (!CLASS_DATA (sym
)->attr
.dimension
2552 && !(CLASS_DATA (sym
)->attr
.codimension
2553 && CLASS_DATA (sym
)->attr
.allocatable
))))
2554 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2557 /* Dereference scalar hidden result. */
2558 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2559 && (sym
->attr
.function
|| sym
->attr
.result
)
2560 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2561 && !sym
->attr
.always_explicit
)
2562 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2565 /* Dereference non-character, non-class pointer variables.
2566 These must be dummies, results, or scalars. */
2568 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2569 || gfc_is_associate_pointer (sym
)
2570 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2572 || sym
->attr
.function
2574 || (!sym
->attr
.dimension
2575 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2576 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2578 /* Now treat the class array pointer variables accordingly. */
2579 else if (sym
->ts
.type
== BT_CLASS
2581 && (CLASS_DATA (sym
)->attr
.dimension
2582 || CLASS_DATA (sym
)->attr
.codimension
)
2583 && ((CLASS_DATA (sym
)->as
2584 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2585 || CLASS_DATA (sym
)->attr
.allocatable
2586 || CLASS_DATA (sym
)->attr
.class_pointer
))
2587 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2589 /* And the case where a non-dummy, non-result, non-function,
2590 non-allotable and non-pointer classarray is present. This case was
2591 previously covered by the first if, but with introducing the
2592 condition !is_classarray there, that case has to be covered
2594 else if (sym
->ts
.type
== BT_CLASS
2596 && !sym
->attr
.function
2597 && !sym
->attr
.result
2598 && (CLASS_DATA (sym
)->attr
.dimension
2599 || CLASS_DATA (sym
)->attr
.codimension
)
2601 || !CLASS_DATA (sym
)->attr
.allocatable
)
2602 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2603 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2610 /* For character variables, also get the length. */
2611 if (sym
->ts
.type
== BT_CHARACTER
)
2613 /* If the character length of an entry isn't set, get the length from
2614 the master function instead. */
2615 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2616 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2618 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2619 gcc_assert (se
->string_length
);
2627 /* Return the descriptor if that's what we want and this is an array
2628 section reference. */
2629 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2631 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2632 /* Return the descriptor for array pointers and allocations. */
2633 if (se
->want_pointer
2634 && ref
->next
== NULL
&& (se
->descriptor_only
))
2637 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2638 /* Return a pointer to an element. */
2642 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2643 && se
->descriptor_only
2644 && !CLASS_DATA (sym
)->attr
.allocatable
2645 && !CLASS_DATA (sym
)->attr
.class_pointer
2646 && CLASS_DATA (sym
)->as
2647 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2648 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2649 /* Skip the first ref of a _data component, because for class
2650 arrays that one is already done by introducing a temporary
2651 array descriptor. */
2654 if (ref
->u
.c
.sym
->attr
.extension
)
2655 conv_parent_component_references (se
, ref
);
2657 gfc_conv_component_ref (se
, ref
);
2658 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2659 && se
->want_pointer
&& se
->descriptor_only
)
2665 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2666 expr
->symtree
->name
, &expr
->where
);
2676 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2678 if (se
->want_pointer
)
2680 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2681 gfc_conv_string_parameter (se
);
2683 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2688 /* Unary ops are easy... Or they would be if ! was a valid op. */
2691 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2696 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2697 /* Initialize the operand. */
2698 gfc_init_se (&operand
, se
);
2699 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2700 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2702 type
= gfc_typenode_for_spec (&expr
->ts
);
2704 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2705 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2706 All other unary operators have an equivalent GIMPLE unary operator. */
2707 if (code
== TRUTH_NOT_EXPR
)
2708 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2709 build_int_cst (type
, 0));
2711 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2715 /* Expand power operator to optimal multiplications when a value is raised
2716 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2717 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2718 Programming", 3rd Edition, 1998. */
2720 /* This code is mostly duplicated from expand_powi in the backend.
2721 We establish the "optimal power tree" lookup table with the defined size.
2722 The items in the table are the exponents used to calculate the index
2723 exponents. Any integer n less than the value can get an "addition chain",
2724 with the first node being one. */
2725 #define POWI_TABLE_SIZE 256
2727 /* The table is from builtins.c. */
2728 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2730 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2731 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2732 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2733 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2734 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2735 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2736 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2737 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2738 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2739 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2740 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2741 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2742 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2743 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2744 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2745 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2746 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2747 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2748 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2749 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2750 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2751 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2752 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2753 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2754 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2755 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2756 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2757 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2758 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2759 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2760 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2761 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2764 /* If n is larger than lookup table's max index, we use the "window
2766 #define POWI_WINDOW_SIZE 3
2768 /* Recursive function to expand the power operator. The temporary
2769 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2771 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2778 if (n
< POWI_TABLE_SIZE
)
2783 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2784 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2788 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2789 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2790 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2794 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2798 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2799 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2801 if (n
< POWI_TABLE_SIZE
)
2808 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2809 return 1. Else return 0 and a call to runtime library functions
2810 will have to be built. */
2812 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2817 tree vartmp
[POWI_TABLE_SIZE
];
2819 unsigned HOST_WIDE_INT n
;
2821 wide_int wrhs
= rhs
;
2823 /* If exponent is too large, we won't expand it anyway, so don't bother
2824 with large integer values. */
2825 if (!wi::fits_shwi_p (wrhs
))
2828 m
= wrhs
.to_shwi ();
2829 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2830 of the asymmetric range of the integer type. */
2831 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2833 type
= TREE_TYPE (lhs
);
2834 sgn
= tree_int_cst_sgn (rhs
);
2836 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2837 || optimize_size
) && (m
> 2 || m
< -1))
2843 se
->expr
= gfc_build_const (type
, integer_one_node
);
2847 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2848 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2850 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2851 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2852 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2853 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2856 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2859 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2860 boolean_type_node
, tmp
, cond
);
2861 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2862 tmp
, build_int_cst (type
, 1),
2863 build_int_cst (type
, 0));
2867 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2868 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2869 build_int_cst (type
, -1),
2870 build_int_cst (type
, 0));
2871 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2872 cond
, build_int_cst (type
, 1), tmp
);
2876 memset (vartmp
, 0, sizeof (vartmp
));
2880 tmp
= gfc_build_const (type
, integer_one_node
);
2881 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2885 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2891 /* Power op (**). Constant integer exponent has special handling. */
2894 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2896 tree gfc_int4_type_node
;
2899 int res_ikind_1
, res_ikind_2
;
2904 gfc_init_se (&lse
, se
);
2905 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2906 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2907 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2909 gfc_init_se (&rse
, se
);
2910 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2911 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2913 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2914 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2915 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2918 gfc_int4_type_node
= gfc_get_int_type (4);
2920 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2921 library routine. But in the end, we have to convert the result back
2922 if this case applies -- with res_ikind_K, we keep track whether operand K
2923 falls into this case. */
2927 kind
= expr
->value
.op
.op1
->ts
.kind
;
2928 switch (expr
->value
.op
.op2
->ts
.type
)
2931 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2936 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2937 res_ikind_2
= ikind
;
2959 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2961 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2988 switch (expr
->value
.op
.op1
->ts
.type
)
2991 if (kind
== 3) /* Case 16 was not handled properly above. */
2993 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2997 /* Use builtins for real ** int4. */
3003 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
3007 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
3011 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3015 /* Use the __builtin_powil() only if real(kind=16) is
3016 actually the C long double type. */
3017 if (!gfc_real16_is_float128
)
3018 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
3026 /* If we don't have a good builtin for this, go for the
3027 library function. */
3029 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
3033 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3042 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3046 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3054 se
->expr
= build_call_expr_loc (input_location
,
3055 fndecl
, 2, lse
.expr
, rse
.expr
);
3057 /* Convert the result back if it is of wrong integer kind. */
3058 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3060 /* We want the maximum of both operand kinds as result. */
3061 if (res_ikind_1
< res_ikind_2
)
3062 res_ikind_1
= res_ikind_2
;
3063 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3068 /* Generate code to allocate a string temporary. */
3071 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3076 if (gfc_can_put_var_on_stack (len
))
3078 /* Create a temporary variable to hold the result. */
3079 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3080 gfc_charlen_type_node
, len
,
3081 build_int_cst (gfc_charlen_type_node
, 1));
3082 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3084 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3085 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3087 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3089 var
= gfc_create_var (tmp
, "str");
3090 var
= gfc_build_addr_expr (type
, var
);
3094 /* Allocate a temporary to hold the result. */
3095 var
= gfc_create_var (type
, "pstr");
3096 gcc_assert (POINTER_TYPE_P (type
));
3097 tmp
= TREE_TYPE (type
);
3098 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3099 tmp
= TREE_TYPE (tmp
);
3100 tmp
= TYPE_SIZE_UNIT (tmp
);
3101 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3102 fold_convert (size_type_node
, len
),
3103 fold_convert (size_type_node
, tmp
));
3104 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3105 gfc_add_modify (&se
->pre
, var
, tmp
);
3107 /* Free the temporary afterwards. */
3108 tmp
= gfc_call_free (var
);
3109 gfc_add_expr_to_block (&se
->post
, tmp
);
3116 /* Handle a string concatenation operation. A temporary will be allocated to
3120 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3123 tree len
, type
, var
, tmp
, fndecl
;
3125 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3126 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3127 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3129 gfc_init_se (&lse
, se
);
3130 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3131 gfc_conv_string_parameter (&lse
);
3132 gfc_init_se (&rse
, se
);
3133 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3134 gfc_conv_string_parameter (&rse
);
3136 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3137 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3139 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3140 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3141 if (len
== NULL_TREE
)
3143 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3144 TREE_TYPE (lse
.string_length
),
3145 lse
.string_length
, rse
.string_length
);
3148 type
= build_pointer_type (type
);
3150 var
= gfc_conv_string_tmp (se
, type
, len
);
3152 /* Do the actual concatenation. */
3153 if (expr
->ts
.kind
== 1)
3154 fndecl
= gfor_fndecl_concat_string
;
3155 else if (expr
->ts
.kind
== 4)
3156 fndecl
= gfor_fndecl_concat_string_char4
;
3160 tmp
= build_call_expr_loc (input_location
,
3161 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3162 rse
.string_length
, rse
.expr
);
3163 gfc_add_expr_to_block (&se
->pre
, tmp
);
3165 /* Add the cleanup for the operands. */
3166 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3167 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3170 se
->string_length
= len
;
3173 /* Translates an op expression. Common (binary) cases are handled by this
3174 function, others are passed on. Recursion is used in either case.
3175 We use the fact that (op1.ts == op2.ts) (except for the power
3177 Operators need no special handling for scalarized expressions as long as
3178 they call gfc_conv_simple_val to get their operands.
3179 Character strings get special handling. */
3182 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3184 enum tree_code code
;
3193 switch (expr
->value
.op
.op
)
3195 case INTRINSIC_PARENTHESES
:
3196 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3197 && flag_protect_parens
)
3199 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3200 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3205 case INTRINSIC_UPLUS
:
3206 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3209 case INTRINSIC_UMINUS
:
3210 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3214 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3217 case INTRINSIC_PLUS
:
3221 case INTRINSIC_MINUS
:
3225 case INTRINSIC_TIMES
:
3229 case INTRINSIC_DIVIDE
:
3230 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3231 an integer, we must round towards zero, so we use a
3233 if (expr
->ts
.type
== BT_INTEGER
)
3234 code
= TRUNC_DIV_EXPR
;
3239 case INTRINSIC_POWER
:
3240 gfc_conv_power_op (se
, expr
);
3243 case INTRINSIC_CONCAT
:
3244 gfc_conv_concat_op (se
, expr
);
3248 code
= TRUTH_ANDIF_EXPR
;
3253 code
= TRUTH_ORIF_EXPR
;
3257 /* EQV and NEQV only work on logicals, but since we represent them
3258 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3260 case INTRINSIC_EQ_OS
:
3268 case INTRINSIC_NE_OS
:
3269 case INTRINSIC_NEQV
:
3276 case INTRINSIC_GT_OS
:
3283 case INTRINSIC_GE_OS
:
3290 case INTRINSIC_LT_OS
:
3297 case INTRINSIC_LE_OS
:
3303 case INTRINSIC_USER
:
3304 case INTRINSIC_ASSIGN
:
3305 /* These should be converted into function calls by the frontend. */
3309 fatal_error (input_location
, "Unknown intrinsic op");
3313 /* The only exception to this is **, which is handled separately anyway. */
3314 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3316 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3320 gfc_init_se (&lse
, se
);
3321 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3322 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3325 gfc_init_se (&rse
, se
);
3326 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3327 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3331 gfc_conv_string_parameter (&lse
);
3332 gfc_conv_string_parameter (&rse
);
3334 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3335 rse
.string_length
, rse
.expr
,
3336 expr
->value
.op
.op1
->ts
.kind
,
3338 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3339 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3342 type
= gfc_typenode_for_spec (&expr
->ts
);
3346 /* The result of logical ops is always boolean_type_node. */
3347 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3348 lse
.expr
, rse
.expr
);
3349 se
->expr
= convert (type
, tmp
);
3352 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3354 /* Add the post blocks. */
3355 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3356 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3359 /* If a string's length is one, we convert it to a single character. */
3362 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3366 || !tree_fits_uhwi_p (len
)
3367 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3370 if (TREE_INT_CST_LOW (len
) == 1)
3372 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3373 return build_fold_indirect_ref_loc (input_location
, str
);
3377 && TREE_CODE (str
) == ADDR_EXPR
3378 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3379 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3380 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3381 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3382 && TREE_INT_CST_LOW (len
) > 1
3383 && TREE_INT_CST_LOW (len
)
3384 == (unsigned HOST_WIDE_INT
)
3385 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3387 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3388 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3389 if (TREE_CODE (ret
) == INTEGER_CST
)
3391 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3392 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3393 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3395 for (i
= 1; i
< length
; i
++)
3408 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3411 if (sym
->backend_decl
)
3413 /* This becomes the nominal_type in
3414 function.c:assign_parm_find_data_types. */
3415 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3416 /* This becomes the passed_type in
3417 function.c:assign_parm_find_data_types. C promotes char to
3418 integer for argument passing. */
3419 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3421 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3426 /* If we have a constant character expression, make it into an
3428 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3433 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3434 (int)(*expr
)->value
.character
.string
[0]);
3435 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3437 /* The expr needs to be compatible with a C int. If the
3438 conversion fails, then the 2 causes an ICE. */
3439 ts
.type
= BT_INTEGER
;
3440 ts
.kind
= gfc_c_int_kind
;
3441 gfc_convert_type (*expr
, &ts
, 2);
3444 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3446 if ((*expr
)->ref
== NULL
)
3448 se
->expr
= gfc_string_to_single_character
3449 (build_int_cst (integer_type_node
, 1),
3450 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3452 ((*expr
)->symtree
->n
.sym
)),
3457 gfc_conv_variable (se
, *expr
);
3458 se
->expr
= gfc_string_to_single_character
3459 (build_int_cst (integer_type_node
, 1),
3460 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3468 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3469 if STR is a string literal, otherwise return -1. */
3472 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3475 && TREE_CODE (str
) == ADDR_EXPR
3476 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3477 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3478 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3479 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3480 && tree_fits_uhwi_p (len
)
3481 && tree_to_uhwi (len
) >= 1
3482 && tree_to_uhwi (len
)
3483 == (unsigned HOST_WIDE_INT
)
3484 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3486 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3487 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3488 if (TREE_CODE (folded
) == INTEGER_CST
)
3490 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3491 int length
= TREE_STRING_LENGTH (string_cst
);
3492 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3494 for (; length
> 0; length
--)
3495 if (ptr
[length
- 1] != ' ')
3504 /* Helper to build a call to memcmp. */
3507 build_memcmp_call (tree s1
, tree s2
, tree n
)
3511 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3512 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3514 s1
= fold_convert (pvoid_type_node
, s1
);
3516 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3517 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3519 s2
= fold_convert (pvoid_type_node
, s2
);
3521 n
= fold_convert (size_type_node
, n
);
3523 tmp
= build_call_expr_loc (input_location
,
3524 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3527 return fold_convert (integer_type_node
, tmp
);
3530 /* Compare two strings. If they are all single characters, the result is the
3531 subtraction of them. Otherwise, we build a library call. */
3534 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3535 enum tree_code code
)
3541 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3542 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3544 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3545 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3547 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3549 /* Deal with single character specially. */
3550 sc1
= fold_convert (integer_type_node
, sc1
);
3551 sc2
= fold_convert (integer_type_node
, sc2
);
3552 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3556 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3558 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3560 /* If one string is a string literal with LEN_TRIM longer
3561 than the length of the second string, the strings
3563 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3564 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3565 return integer_one_node
;
3566 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3567 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3568 return integer_one_node
;
3571 /* We can compare via memcpy if the strings are known to be equal
3572 in length and they are
3574 - kind=4 and the comparison is for (in)equality. */
3576 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3577 && tree_int_cst_equal (len1
, len2
)
3578 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3583 chartype
= gfc_get_char_type (kind
);
3584 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3585 fold_convert (TREE_TYPE(len1
),
3586 TYPE_SIZE_UNIT(chartype
)),
3588 return build_memcmp_call (str1
, str2
, tmp
);
3591 /* Build a call for the comparison. */
3593 fndecl
= gfor_fndecl_compare_string
;
3595 fndecl
= gfor_fndecl_compare_string_char4
;
3599 return build_call_expr_loc (input_location
, fndecl
, 4,
3600 len1
, str1
, len2
, str2
);
3604 /* Return the backend_decl for a procedure pointer component. */
3607 get_proc_ptr_comp (gfc_expr
*e
)
3613 gfc_init_se (&comp_se
, NULL
);
3614 e2
= gfc_copy_expr (e
);
3615 /* We have to restore the expr type later so that gfc_free_expr frees
3616 the exact same thing that was allocated.
3617 TODO: This is ugly. */
3618 old_type
= e2
->expr_type
;
3619 e2
->expr_type
= EXPR_VARIABLE
;
3620 gfc_conv_expr (&comp_se
, e2
);
3621 e2
->expr_type
= old_type
;
3623 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3627 /* Convert a typebound function reference from a class object. */
3629 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3634 if (TREE_CODE (base_object
) != VAR_DECL
)
3636 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3637 gfc_add_modify (&se
->pre
, var
, base_object
);
3639 se
->expr
= gfc_class_vptr_get (base_object
);
3640 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3642 while (ref
&& ref
->next
)
3644 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3645 if (ref
->u
.c
.sym
->attr
.extension
)
3646 conv_parent_component_references (se
, ref
);
3647 gfc_conv_component_ref (se
, ref
);
3648 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3653 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3657 if (gfc_is_proc_ptr_comp (expr
))
3658 tmp
= get_proc_ptr_comp (expr
);
3659 else if (sym
->attr
.dummy
)
3661 tmp
= gfc_get_symbol_decl (sym
);
3662 if (sym
->attr
.proc_pointer
)
3663 tmp
= build_fold_indirect_ref_loc (input_location
,
3665 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3666 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3670 if (!sym
->backend_decl
)
3671 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3673 TREE_USED (sym
->backend_decl
) = 1;
3675 tmp
= sym
->backend_decl
;
3677 if (sym
->attr
.cray_pointee
)
3679 /* TODO - make the cray pointee a pointer to a procedure,
3680 assign the pointer to it and use it for the call. This
3682 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3683 gfc_get_symbol_decl (sym
->cp_pointer
));
3684 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3687 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3689 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3690 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3697 /* Initialize MAPPING. */
3700 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3702 mapping
->syms
= NULL
;
3703 mapping
->charlens
= NULL
;
3707 /* Free all memory held by MAPPING (but not MAPPING itself). */
3710 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3712 gfc_interface_sym_mapping
*sym
;
3713 gfc_interface_sym_mapping
*nextsym
;
3715 gfc_charlen
*nextcl
;
3717 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3719 nextsym
= sym
->next
;
3720 sym
->new_sym
->n
.sym
->formal
= NULL
;
3721 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3722 gfc_free_expr (sym
->expr
);
3723 free (sym
->new_sym
);
3726 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3729 gfc_free_expr (cl
->length
);
3735 /* Return a copy of gfc_charlen CL. Add the returned structure to
3736 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3738 static gfc_charlen
*
3739 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3742 gfc_charlen
*new_charlen
;
3744 new_charlen
= gfc_get_charlen ();
3745 new_charlen
->next
= mapping
->charlens
;
3746 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3748 mapping
->charlens
= new_charlen
;
3753 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3754 array variable that can be used as the actual argument for dummy
3755 argument SYM. Add any initialization code to BLOCK. PACKED is as
3756 for gfc_get_nodesc_array_type and DATA points to the first element
3757 in the passed array. */
3760 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3761 gfc_packed packed
, tree data
)
3766 type
= gfc_typenode_for_spec (&sym
->ts
);
3767 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3768 !sym
->attr
.target
&& !sym
->attr
.pointer
3769 && !sym
->attr
.proc_pointer
);
3771 var
= gfc_create_var (type
, "ifm");
3772 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3778 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3779 and offset of descriptorless array type TYPE given that it has the same
3780 size as DESC. Add any set-up code to BLOCK. */
3783 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3790 offset
= gfc_index_zero_node
;
3791 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3793 dim
= gfc_rank_cst
[n
];
3794 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3795 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3797 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3798 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3799 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3800 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3802 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3804 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3805 gfc_array_index_type
,
3806 gfc_conv_descriptor_ubound_get (desc
, dim
),
3807 gfc_conv_descriptor_lbound_get (desc
, dim
));
3808 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3809 gfc_array_index_type
,
3810 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3811 tmp
= gfc_evaluate_now (tmp
, block
);
3812 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3814 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3815 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3816 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3817 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3818 gfc_array_index_type
, offset
, tmp
);
3820 offset
= gfc_evaluate_now (offset
, block
);
3821 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3825 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3826 in SE. The caller may still use se->expr and se->string_length after
3827 calling this function. */
3830 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3831 gfc_symbol
* sym
, gfc_se
* se
,
3834 gfc_interface_sym_mapping
*sm
;
3838 gfc_symbol
*new_sym
;
3840 gfc_symtree
*new_symtree
;
3842 /* Create a new symbol to represent the actual argument. */
3843 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3844 new_sym
->ts
= sym
->ts
;
3845 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3846 new_sym
->attr
.referenced
= 1;
3847 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3848 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3849 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3850 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3851 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3852 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3853 new_sym
->attr
.function
= sym
->attr
.function
;
3855 /* Ensure that the interface is available and that
3856 descriptors are passed for array actual arguments. */
3857 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3859 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3860 new_sym
->attr
.always_explicit
3861 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3864 /* Create a fake symtree for it. */
3866 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3867 new_symtree
->n
.sym
= new_sym
;
3868 gcc_assert (new_symtree
== root
);
3870 /* Create a dummy->actual mapping. */
3871 sm
= XCNEW (gfc_interface_sym_mapping
);
3872 sm
->next
= mapping
->syms
;
3874 sm
->new_sym
= new_symtree
;
3875 sm
->expr
= gfc_copy_expr (expr
);
3878 /* Stabilize the argument's value. */
3879 if (!sym
->attr
.function
&& se
)
3880 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3882 if (sym
->ts
.type
== BT_CHARACTER
)
3884 /* Create a copy of the dummy argument's length. */
3885 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3886 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3888 /* If the length is specified as "*", record the length that
3889 the caller is passing. We should use the callee's length
3890 in all other cases. */
3891 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3893 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3894 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3901 /* Use the passed value as-is if the argument is a function. */
3902 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3905 /* If the argument is either a string or a pointer to a string,
3906 convert it to a boundless character type. */
3907 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3909 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3910 tmp
= build_pointer_type (tmp
);
3911 if (sym
->attr
.pointer
)
3912 value
= build_fold_indirect_ref_loc (input_location
,
3916 value
= fold_convert (tmp
, value
);
3919 /* If the argument is a scalar, a pointer to an array or an allocatable,
3921 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3922 value
= build_fold_indirect_ref_loc (input_location
,
3925 /* For character(*), use the actual argument's descriptor. */
3926 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3927 value
= build_fold_indirect_ref_loc (input_location
,
3930 /* If the argument is an array descriptor, use it to determine
3931 information about the actual argument's shape. */
3932 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3933 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3935 /* Get the actual argument's descriptor. */
3936 desc
= build_fold_indirect_ref_loc (input_location
,
3939 /* Create the replacement variable. */
3940 tmp
= gfc_conv_descriptor_data_get (desc
);
3941 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3944 /* Use DESC to work out the upper bounds, strides and offset. */
3945 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3948 /* Otherwise we have a packed array. */
3949 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3950 PACKED_FULL
, se
->expr
);
3952 new_sym
->backend_decl
= value
;
3956 /* Called once all dummy argument mappings have been added to MAPPING,
3957 but before the mapping is used to evaluate expressions. Pre-evaluate
3958 the length of each argument, adding any initialization code to PRE and
3959 any finalization code to POST. */
3962 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3963 stmtblock_t
* pre
, stmtblock_t
* post
)
3965 gfc_interface_sym_mapping
*sym
;
3969 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3970 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3971 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3973 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3974 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3975 gfc_init_se (&se
, NULL
);
3976 gfc_conv_expr (&se
, expr
);
3977 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3978 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3979 gfc_add_block_to_block (pre
, &se
.pre
);
3980 gfc_add_block_to_block (post
, &se
.post
);
3982 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3987 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3991 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3992 gfc_constructor_base base
)
3995 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3997 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
4000 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
4001 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
4002 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
4008 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4012 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
4017 for (; ref
; ref
= ref
->next
)
4021 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4023 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
4024 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
4025 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
4033 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
4034 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4040 /* Convert intrinsic function calls into result expressions. */
4043 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4051 arg1
= expr
->value
.function
.actual
->expr
;
4052 if (expr
->value
.function
.actual
->next
)
4053 arg2
= expr
->value
.function
.actual
->next
->expr
;
4057 sym
= arg1
->symtree
->n
.sym
;
4059 if (sym
->attr
.dummy
)
4064 switch (expr
->value
.function
.isym
->id
)
4067 /* TODO figure out why this condition is necessary. */
4068 if (sym
->attr
.function
4069 && (arg1
->ts
.u
.cl
->length
== NULL
4070 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4071 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4074 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4078 if (!sym
->as
|| sym
->as
->rank
== 0)
4081 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4083 dup
= mpz_get_si (arg2
->value
.integer
);
4088 dup
= sym
->as
->rank
;
4092 for (; d
< dup
; d
++)
4096 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4098 gfc_free_expr (new_expr
);
4102 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4103 gfc_get_int_expr (gfc_default_integer_kind
,
4105 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4107 new_expr
= gfc_multiply (new_expr
, tmp
);
4113 case GFC_ISYM_LBOUND
:
4114 case GFC_ISYM_UBOUND
:
4115 /* TODO These implementations of lbound and ubound do not limit if
4116 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4118 if (!sym
->as
|| sym
->as
->rank
== 0)
4121 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4122 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4124 /* TODO: If the need arises, this could produce an array of
4128 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4130 if (sym
->as
->lower
[d
])
4131 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4135 if (sym
->as
->upper
[d
])
4136 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4144 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4148 gfc_replace_expr (expr
, new_expr
);
4154 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4155 gfc_interface_mapping
* mapping
)
4157 gfc_formal_arglist
*f
;
4158 gfc_actual_arglist
*actual
;
4160 actual
= expr
->value
.function
.actual
;
4161 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4163 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4168 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4171 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4176 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4178 for (d
= 0; d
< as
->rank
; d
++)
4180 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4181 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4184 expr
->value
.function
.esym
->as
= as
;
4187 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4189 expr
->value
.function
.esym
->ts
.u
.cl
->length
4190 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4192 gfc_apply_interface_mapping_to_expr (mapping
,
4193 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4198 /* EXPR is a copy of an expression that appeared in the interface
4199 associated with MAPPING. Walk it recursively looking for references to
4200 dummy arguments that MAPPING maps to actual arguments. Replace each such
4201 reference with a reference to the associated actual argument. */
4204 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4207 gfc_interface_sym_mapping
*sym
;
4208 gfc_actual_arglist
*actual
;
4213 /* Copying an expression does not copy its length, so do that here. */
4214 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4216 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4217 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4220 /* Apply the mapping to any references. */
4221 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4223 /* ...and to the expression's symbol, if it has one. */
4224 /* TODO Find out why the condition on expr->symtree had to be moved into
4225 the loop rather than being outside it, as originally. */
4226 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4227 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4229 if (sym
->new_sym
->n
.sym
->backend_decl
)
4230 expr
->symtree
= sym
->new_sym
;
4232 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4235 /* ...and to subexpressions in expr->value. */
4236 switch (expr
->expr_type
)
4241 case EXPR_SUBSTRING
:
4245 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4246 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4250 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4251 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4253 if (expr
->value
.function
.esym
== NULL
4254 && expr
->value
.function
.isym
!= NULL
4255 && expr
->value
.function
.actual
->expr
->symtree
4256 && gfc_map_intrinsic_function (expr
, mapping
))
4259 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4260 if (sym
->old
== expr
->value
.function
.esym
)
4262 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4263 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4264 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4269 case EXPR_STRUCTURE
:
4270 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4283 /* Evaluate interface expression EXPR using MAPPING. Store the result
4287 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4288 gfc_se
* se
, gfc_expr
* expr
)
4290 expr
= gfc_copy_expr (expr
);
4291 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4292 gfc_conv_expr (se
, expr
);
4293 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4294 gfc_free_expr (expr
);
4298 /* Returns a reference to a temporary array into which a component of
4299 an actual argument derived type array is copied and then returned
4300 after the function call. */
4302 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4303 sym_intent intent
, bool formal_ptr
)
4311 gfc_array_info
*info
;
4321 gfc_init_se (&lse
, NULL
);
4322 gfc_init_se (&rse
, NULL
);
4324 /* Walk the argument expression. */
4325 rss
= gfc_walk_expr (expr
);
4327 gcc_assert (rss
!= gfc_ss_terminator
);
4329 /* Initialize the scalarizer. */
4330 gfc_init_loopinfo (&loop
);
4331 gfc_add_ss_to_loop (&loop
, rss
);
4333 /* Calculate the bounds of the scalarization. */
4334 gfc_conv_ss_startstride (&loop
);
4336 /* Build an ss for the temporary. */
4337 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4338 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4340 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4341 if (GFC_ARRAY_TYPE_P (base_type
)
4342 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4343 base_type
= gfc_get_element_type (base_type
);
4345 if (expr
->ts
.type
== BT_CLASS
)
4346 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4348 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4349 ? expr
->ts
.u
.cl
->backend_decl
4353 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4355 /* Associate the SS with the loop. */
4356 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4358 /* Setup the scalarizing loops. */
4359 gfc_conv_loop_setup (&loop
, &expr
->where
);
4361 /* Pass the temporary descriptor back to the caller. */
4362 info
= &loop
.temp_ss
->info
->data
.array
;
4363 parmse
->expr
= info
->descriptor
;
4365 /* Setup the gfc_se structures. */
4366 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4367 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4370 lse
.ss
= loop
.temp_ss
;
4371 gfc_mark_ss_chain_used (rss
, 1);
4372 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4374 /* Start the scalarized loop body. */
4375 gfc_start_scalarized_body (&loop
, &body
);
4377 /* Translate the expression. */
4378 gfc_conv_expr (&rse
, expr
);
4380 /* Reset the offset for the function call since the loop
4381 is zero based on the data pointer. Note that the temp
4382 comes first in the loop chain since it is added second. */
4383 if (gfc_is_alloc_class_array_function (expr
))
4385 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4386 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4387 gfc_index_zero_node
);
4390 gfc_conv_tmp_array_ref (&lse
);
4392 if (intent
!= INTENT_OUT
)
4394 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4395 gfc_add_expr_to_block (&body
, tmp
);
4396 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4397 gfc_trans_scalarizing_loops (&loop
, &body
);
4401 /* Make sure that the temporary declaration survives by merging
4402 all the loop declarations into the current context. */
4403 for (n
= 0; n
< loop
.dimen
; n
++)
4405 gfc_merge_block_scope (&body
);
4406 body
= loop
.code
[loop
.order
[n
]];
4408 gfc_merge_block_scope (&body
);
4411 /* Add the post block after the second loop, so that any
4412 freeing of allocated memory is done at the right time. */
4413 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4415 /**********Copy the temporary back again.*********/
4417 gfc_init_se (&lse
, NULL
);
4418 gfc_init_se (&rse
, NULL
);
4420 /* Walk the argument expression. */
4421 lss
= gfc_walk_expr (expr
);
4422 rse
.ss
= loop
.temp_ss
;
4425 /* Initialize the scalarizer. */
4426 gfc_init_loopinfo (&loop2
);
4427 gfc_add_ss_to_loop (&loop2
, lss
);
4429 dimen
= rse
.ss
->dimen
;
4431 /* Skip the write-out loop for this case. */
4432 if (gfc_is_alloc_class_array_function (expr
))
4433 goto class_array_fcn
;
4435 /* Calculate the bounds of the scalarization. */
4436 gfc_conv_ss_startstride (&loop2
);
4438 /* Setup the scalarizing loops. */
4439 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4441 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4442 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4444 gfc_mark_ss_chain_used (lss
, 1);
4445 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4447 /* Declare the variable to hold the temporary offset and start the
4448 scalarized loop body. */
4449 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4450 gfc_start_scalarized_body (&loop2
, &body
);
4452 /* Build the offsets for the temporary from the loop variables. The
4453 temporary array has lbounds of zero and strides of one in all
4454 dimensions, so this is very simple. The offset is only computed
4455 outside the innermost loop, so the overall transfer could be
4456 optimized further. */
4457 info
= &rse
.ss
->info
->data
.array
;
4459 tmp_index
= gfc_index_zero_node
;
4460 for (n
= dimen
- 1; n
> 0; n
--)
4463 tmp
= rse
.loop
->loopvar
[n
];
4464 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4465 tmp
, rse
.loop
->from
[n
]);
4466 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4469 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4470 gfc_array_index_type
,
4471 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4472 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4473 gfc_array_index_type
,
4474 tmp_str
, gfc_index_one_node
);
4476 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4477 gfc_array_index_type
, tmp
, tmp_str
);
4480 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4481 gfc_array_index_type
,
4482 tmp_index
, rse
.loop
->from
[0]);
4483 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4485 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4486 gfc_array_index_type
,
4487 rse
.loop
->loopvar
[0], offset
);
4489 /* Now use the offset for the reference. */
4490 tmp
= build_fold_indirect_ref_loc (input_location
,
4492 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4494 if (expr
->ts
.type
== BT_CHARACTER
)
4495 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4497 gfc_conv_expr (&lse
, expr
);
4499 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4501 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4502 gfc_add_expr_to_block (&body
, tmp
);
4504 /* Generate the copying loops. */
4505 gfc_trans_scalarizing_loops (&loop2
, &body
);
4507 /* Wrap the whole thing up by adding the second loop to the post-block
4508 and following it by the post-block of the first loop. In this way,
4509 if the temporary needs freeing, it is done after use! */
4510 if (intent
!= INTENT_IN
)
4512 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4513 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4518 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4520 gfc_cleanup_loop (&loop
);
4521 gfc_cleanup_loop (&loop2
);
4523 /* Pass the string length to the argument expression. */
4524 if (expr
->ts
.type
== BT_CHARACTER
)
4525 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4527 /* Determine the offset for pointer formal arguments and set the
4531 size
= gfc_index_one_node
;
4532 offset
= gfc_index_zero_node
;
4533 for (n
= 0; n
< dimen
; n
++)
4535 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4537 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4538 gfc_array_index_type
, tmp
,
4539 gfc_index_one_node
);
4540 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4544 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4547 gfc_index_one_node
);
4548 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4549 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4550 gfc_array_index_type
,
4552 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4553 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4554 gfc_array_index_type
,
4555 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4556 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4557 gfc_array_index_type
,
4558 tmp
, gfc_index_one_node
);
4559 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4560 gfc_array_index_type
, size
, tmp
);
4563 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4567 /* We want either the address for the data or the address of the descriptor,
4568 depending on the mode of passing array arguments. */
4570 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4572 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4578 /* Generate the code for argument list functions. */
4581 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4583 /* Pass by value for g77 %VAL(arg), pass the address
4584 indirectly for %LOC, else by reference. Thus %REF
4585 is a "do-nothing" and %LOC is the same as an F95
4587 if (strncmp (name
, "%VAL", 4) == 0)
4588 gfc_conv_expr (se
, expr
);
4589 else if (strncmp (name
, "%LOC", 4) == 0)
4591 gfc_conv_expr_reference (se
, expr
);
4592 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4594 else if (strncmp (name
, "%REF", 4) == 0)
4595 gfc_conv_expr_reference (se
, expr
);
4597 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4601 /* This function tells whether the middle-end representation of the expression
4602 E given as input may point to data otherwise accessible through a variable
4604 It is assumed that the only expressions that may alias are variables,
4605 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4607 This function is used to decide whether freeing an expression's allocatable
4608 components is safe or should be avoided.
4610 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4611 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4612 is necessary because for array constructors, aliasing depends on how
4614 - If E is an array constructor used as argument to an elemental procedure,
4615 the array, which is generated through shallow copy by the scalarizer,
4616 is used directly and can alias the expressions it was copied from.
4617 - If E is an array constructor used as argument to a non-elemental
4618 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4619 the array as in the previous case, but then that array is used
4620 to initialize a new descriptor through deep copy. There is no alias
4621 possible in that case.
4622 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4626 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4630 if (e
->expr_type
== EXPR_VARIABLE
)
4632 else if (e
->expr_type
== EXPR_FUNCTION
)
4634 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4636 if ((proc_ifc
->result
->ts
.type
== BT_CLASS
4637 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4638 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4639 || proc_ifc
->result
->attr
.pointer
)
4644 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4647 for (c
= gfc_constructor_first (e
->value
.constructor
);
4648 c
; c
= gfc_constructor_next (c
))
4650 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4657 /* Generate code for a procedure call. Note can return se->post != NULL.
4658 If se->direct_byref is set then se->expr contains the return parameter.
4659 Return nonzero, if the call has alternate specifiers.
4660 'expr' is only needed for procedure pointer components. */
4663 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4664 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4665 vec
<tree
, va_gc
> *append_args
)
4667 gfc_interface_mapping mapping
;
4668 vec
<tree
, va_gc
> *arglist
;
4669 vec
<tree
, va_gc
> *retargs
;
4673 gfc_array_info
*info
;
4680 vec
<tree
, va_gc
> *stringargs
;
4681 vec
<tree
, va_gc
> *optionalargs
;
4683 gfc_formal_arglist
*formal
;
4684 gfc_actual_arglist
*arg
;
4685 int has_alternate_specifier
= 0;
4686 bool need_interface_mapping
;
4694 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4695 gfc_component
*comp
= NULL
;
4702 optionalargs
= NULL
;
4707 comp
= gfc_get_proc_ptr_comp (expr
);
4709 bool elemental_proc
= (comp
4710 && comp
->ts
.interface
4711 && comp
->ts
.interface
->attr
.elemental
)
4712 || (comp
&& comp
->attr
.elemental
)
4713 || sym
->attr
.elemental
;
4717 if (!elemental_proc
)
4719 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4720 if (se
->ss
->info
->useflags
)
4722 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4723 && sym
->result
->attr
.dimension
)
4724 || (comp
&& comp
->attr
.dimension
)
4725 || gfc_is_alloc_class_array_function (expr
));
4726 gcc_assert (se
->loop
!= NULL
);
4727 /* Access the previously obtained result. */
4728 gfc_conv_tmp_array_ref (se
);
4732 info
= &se
->ss
->info
->data
.array
;
4737 gfc_init_block (&post
);
4738 gfc_init_interface_mapping (&mapping
);
4741 formal
= gfc_sym_get_dummy_args (sym
);
4742 need_interface_mapping
= sym
->attr
.dimension
||
4743 (sym
->ts
.type
== BT_CHARACTER
4744 && sym
->ts
.u
.cl
->length
4745 && sym
->ts
.u
.cl
->length
->expr_type
4750 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4751 need_interface_mapping
= comp
->attr
.dimension
||
4752 (comp
->ts
.type
== BT_CHARACTER
4753 && comp
->ts
.u
.cl
->length
4754 && comp
->ts
.u
.cl
->length
->expr_type
4758 base_object
= NULL_TREE
;
4759 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4760 is the third and fourth argument to such a function call a value
4761 denoting the number of elements to copy (i.e., most of the time the
4762 length of a deferred length string). */
4763 ulim_copy
= (formal
== NULL
)
4764 && UNLIMITED_POLY (sym
)
4765 && comp
&& (strcmp ("_copy", comp
->name
) == 0);
4767 /* Evaluate the arguments. */
4768 for (arg
= args
, argc
= 0; arg
!= NULL
;
4769 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4772 fsym
= formal
? formal
->sym
: NULL
;
4773 parm_kind
= MISSING
;
4775 /* If the procedure requires an explicit interface, the actual
4776 argument is passed according to the corresponding formal
4777 argument. If the corresponding formal argument is a POINTER,
4778 ALLOCATABLE or assumed shape, we do not use g77's calling
4779 convention, and pass the address of the array descriptor
4780 instead. Otherwise we use g77's calling convention, in other words
4781 pass the array data pointer without descriptor. */
4782 bool nodesc_arg
= fsym
!= NULL
4783 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4785 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4786 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4788 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4790 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4792 /* Class array expressions are sometimes coming completely unadorned
4793 with either arrayspec or _data component. Correct that here.
4794 OOP-TODO: Move this to the frontend. */
4795 if (e
&& e
->expr_type
== EXPR_VARIABLE
4797 && e
->ts
.type
== BT_CLASS
4798 && (CLASS_DATA (e
)->attr
.codimension
4799 || CLASS_DATA (e
)->attr
.dimension
))
4801 gfc_typespec temp_ts
= e
->ts
;
4802 gfc_add_class_array_ref (e
);
4808 if (se
->ignore_optional
)
4810 /* Some intrinsics have already been resolved to the correct
4814 else if (arg
->label
)
4816 has_alternate_specifier
= 1;
4821 gfc_init_se (&parmse
, NULL
);
4823 /* For scalar arguments with VALUE attribute which are passed by
4824 value, pass "0" and a hidden argument gives the optional
4826 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4827 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4828 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4830 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4832 vec_safe_push (optionalargs
, boolean_false_node
);
4836 /* Pass a NULL pointer for an absent arg. */
4837 parmse
.expr
= null_pointer_node
;
4838 if (arg
->missing_arg_type
== BT_CHARACTER
)
4839 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4844 else if (arg
->expr
->expr_type
== EXPR_NULL
4845 && fsym
&& !fsym
->attr
.pointer
4846 && (fsym
->ts
.type
!= BT_CLASS
4847 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4849 /* Pass a NULL pointer to denote an absent arg. */
4850 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4851 && (fsym
->ts
.type
!= BT_CLASS
4852 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4853 gfc_init_se (&parmse
, NULL
);
4854 parmse
.expr
= null_pointer_node
;
4855 if (arg
->missing_arg_type
== BT_CHARACTER
)
4856 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4858 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4859 && e
->ts
.type
== BT_DERIVED
)
4861 /* The derived type needs to be converted to a temporary
4863 gfc_init_se (&parmse
, se
);
4864 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4866 && e
->expr_type
== EXPR_VARIABLE
4867 && e
->symtree
->n
.sym
->attr
.optional
,
4868 CLASS_DATA (fsym
)->attr
.class_pointer
4869 || CLASS_DATA (fsym
)->attr
.allocatable
);
4871 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4873 /* The intrinsic type needs to be converted to a temporary
4874 CLASS object for the unlimited polymorphic formal. */
4875 gfc_init_se (&parmse
, se
);
4876 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4878 else if (se
->ss
&& se
->ss
->info
->useflags
)
4884 /* An elemental function inside a scalarized loop. */
4885 gfc_init_se (&parmse
, se
);
4886 parm_kind
= ELEMENTAL
;
4888 /* When no fsym is present, ulim_copy is set and this is a third or
4889 fourth argument, use call-by-value instead of by reference to
4890 hand the length properties to the copy routine (i.e., most of the
4891 time this will be a call to a __copy_character_* routine where the
4892 third and fourth arguments are the lengths of a deferred length
4894 if ((fsym
&& fsym
->attr
.value
)
4895 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4896 gfc_conv_expr (&parmse
, e
);
4898 gfc_conv_expr_reference (&parmse
, e
);
4900 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4901 && e
->expr_type
== EXPR_FUNCTION
)
4902 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4905 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4906 && gfc_is_class_container_ref (e
))
4908 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4910 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4911 && e
->symtree
->n
.sym
->attr
.optional
)
4913 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4914 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4915 TREE_TYPE (parmse
.expr
),
4917 fold_convert (TREE_TYPE (parmse
.expr
),
4918 null_pointer_node
));
4922 /* If we are passing an absent array as optional dummy to an
4923 elemental procedure, make sure that we pass NULL when the data
4924 pointer is NULL. We need this extra conditional because of
4925 scalarization which passes arrays elements to the procedure,
4926 ignoring the fact that the array can be absent/unallocated/... */
4927 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4929 tree descriptor_data
;
4931 descriptor_data
= ss
->info
->data
.array
.data
;
4932 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4934 fold_convert (TREE_TYPE (descriptor_data
),
4935 null_pointer_node
));
4937 = fold_build3_loc (input_location
, COND_EXPR
,
4938 TREE_TYPE (parmse
.expr
),
4939 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4940 fold_convert (TREE_TYPE (parmse
.expr
),
4945 /* The scalarizer does not repackage the reference to a class
4946 array - instead it returns a pointer to the data element. */
4947 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4948 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4949 fsym
->attr
.intent
!= INTENT_IN
4950 && (CLASS_DATA (fsym
)->attr
.class_pointer
4951 || CLASS_DATA (fsym
)->attr
.allocatable
),
4953 && e
->expr_type
== EXPR_VARIABLE
4954 && e
->symtree
->n
.sym
->attr
.optional
,
4955 CLASS_DATA (fsym
)->attr
.class_pointer
4956 || CLASS_DATA (fsym
)->attr
.allocatable
);
4963 gfc_init_se (&parmse
, NULL
);
4965 /* Check whether the expression is a scalar or not; we cannot use
4966 e->rank as it can be nonzero for functions arguments. */
4967 argss
= gfc_walk_expr (e
);
4968 scalar
= argss
== gfc_ss_terminator
;
4970 gfc_free_ss_chain (argss
);
4972 /* Special handling for passing scalar polymorphic coarrays;
4973 otherwise one passes "class->_data.data" instead of "&class". */
4974 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4975 && fsym
&& fsym
->ts
.type
== BT_CLASS
4976 && CLASS_DATA (fsym
)->attr
.codimension
4977 && !CLASS_DATA (fsym
)->attr
.dimension
)
4979 gfc_add_class_array_ref (e
);
4980 parmse
.want_coarray
= 1;
4984 /* A scalar or transformational function. */
4987 if (e
->expr_type
== EXPR_VARIABLE
4988 && e
->symtree
->n
.sym
->attr
.cray_pointee
4989 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4991 /* The Cray pointer needs to be converted to a pointer to
4992 a type given by the expression. */
4993 gfc_conv_expr (&parmse
, e
);
4994 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4995 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4996 parmse
.expr
= convert (type
, tmp
);
4998 else if (fsym
&& fsym
->attr
.value
)
5000 if (fsym
->ts
.type
== BT_CHARACTER
5001 && fsym
->ts
.is_c_interop
5002 && fsym
->ns
->proc_name
!= NULL
5003 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
5006 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
5007 if (parmse
.expr
== NULL
)
5008 gfc_conv_expr (&parmse
, e
);
5012 gfc_conv_expr (&parmse
, e
);
5013 if (fsym
->attr
.optional
5014 && fsym
->ts
.type
!= BT_CLASS
5015 && fsym
->ts
.type
!= BT_DERIVED
)
5017 if (e
->expr_type
!= EXPR_VARIABLE
5018 || !e
->symtree
->n
.sym
->attr
.optional
5020 vec_safe_push (optionalargs
, boolean_true_node
);
5023 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5024 if (!e
->symtree
->n
.sym
->attr
.value
)
5026 = fold_build3_loc (input_location
, COND_EXPR
,
5027 TREE_TYPE (parmse
.expr
),
5029 fold_convert (TREE_TYPE (parmse
.expr
),
5030 integer_zero_node
));
5032 vec_safe_push (optionalargs
, tmp
);
5037 else if (arg
->name
&& arg
->name
[0] == '%')
5038 /* Argument list functions %VAL, %LOC and %REF are signalled
5039 through arg->name. */
5040 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5041 else if ((e
->expr_type
== EXPR_FUNCTION
)
5042 && ((e
->value
.function
.esym
5043 && e
->value
.function
.esym
->result
->attr
.pointer
)
5044 || (!e
->value
.function
.esym
5045 && e
->symtree
->n
.sym
->attr
.pointer
))
5046 && fsym
&& fsym
->attr
.target
)
5048 gfc_conv_expr (&parmse
, e
);
5049 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5051 else if (e
->expr_type
== EXPR_FUNCTION
5052 && e
->symtree
->n
.sym
->result
5053 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5054 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5056 /* Functions returning procedure pointers. */
5057 gfc_conv_expr (&parmse
, e
);
5058 if (fsym
&& fsym
->attr
.proc_pointer
)
5059 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5063 if (e
->ts
.type
== BT_CLASS
&& fsym
5064 && fsym
->ts
.type
== BT_CLASS
5065 && (!CLASS_DATA (fsym
)->as
5066 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5067 && CLASS_DATA (e
)->attr
.codimension
)
5069 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5070 gcc_assert (!CLASS_DATA (fsym
)->as
);
5071 gfc_add_class_array_ref (e
);
5072 parmse
.want_coarray
= 1;
5073 gfc_conv_expr_reference (&parmse
, e
);
5074 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5076 && e
->expr_type
== EXPR_VARIABLE
);
5078 else if (e
->ts
.type
== BT_CLASS
&& fsym
5079 && fsym
->ts
.type
== BT_CLASS
5080 && !CLASS_DATA (fsym
)->as
5081 && !CLASS_DATA (e
)->as
5082 && strcmp (fsym
->ts
.u
.derived
->name
,
5083 e
->ts
.u
.derived
->name
))
5085 type
= gfc_typenode_for_spec (&fsym
->ts
);
5086 var
= gfc_create_var (type
, fsym
->name
);
5087 gfc_conv_expr (&parmse
, e
);
5088 if (fsym
->attr
.optional
5089 && e
->expr_type
== EXPR_VARIABLE
5090 && e
->symtree
->n
.sym
->attr
.optional
)
5094 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5095 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5096 boolean_type_node
, tmp
,
5097 fold_convert (TREE_TYPE (tmp
),
5098 null_pointer_node
));
5099 gfc_start_block (&block
);
5100 gfc_add_modify (&block
, var
,
5101 fold_build1_loc (input_location
,
5103 type
, parmse
.expr
));
5104 gfc_add_expr_to_block (&parmse
.pre
,
5105 fold_build3_loc (input_location
,
5106 COND_EXPR
, void_type_node
,
5107 cond
, gfc_finish_block (&block
),
5108 build_empty_stmt (input_location
)));
5109 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5110 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5111 TREE_TYPE (parmse
.expr
),
5113 fold_convert (TREE_TYPE (parmse
.expr
),
5114 null_pointer_node
));
5118 gfc_add_modify (&parmse
.pre
, var
,
5119 fold_build1_loc (input_location
,
5121 type
, parmse
.expr
));
5122 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5126 gfc_conv_expr_reference (&parmse
, e
);
5128 /* Catch base objects that are not variables. */
5129 if (e
->ts
.type
== BT_CLASS
5130 && e
->expr_type
!= EXPR_VARIABLE
5131 && expr
&& e
== expr
->base_expr
)
5132 base_object
= build_fold_indirect_ref_loc (input_location
,
5135 /* A class array element needs converting back to be a
5136 class object, if the formal argument is a class object. */
5137 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5138 && e
->ts
.type
== BT_CLASS
5139 && ((CLASS_DATA (fsym
)->as
5140 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5141 || CLASS_DATA (e
)->attr
.dimension
))
5142 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5143 fsym
->attr
.intent
!= INTENT_IN
5144 && (CLASS_DATA (fsym
)->attr
.class_pointer
5145 || CLASS_DATA (fsym
)->attr
.allocatable
),
5147 && e
->expr_type
== EXPR_VARIABLE
5148 && e
->symtree
->n
.sym
->attr
.optional
,
5149 CLASS_DATA (fsym
)->attr
.class_pointer
5150 || CLASS_DATA (fsym
)->attr
.allocatable
);
5152 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5153 allocated on entry, it must be deallocated. */
5154 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5155 && (fsym
->attr
.allocatable
5156 || (fsym
->ts
.type
== BT_CLASS
5157 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5162 gfc_init_block (&block
);
5164 if (e
->ts
.type
== BT_CLASS
)
5165 ptr
= gfc_class_data_get (ptr
);
5167 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5169 gfc_add_expr_to_block (&block
, tmp
);
5170 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5171 void_type_node
, ptr
,
5173 gfc_add_expr_to_block (&block
, tmp
);
5175 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5177 gfc_add_modify (&block
, ptr
,
5178 fold_convert (TREE_TYPE (ptr
),
5179 null_pointer_node
));
5180 gfc_add_expr_to_block (&block
, tmp
);
5182 else if (fsym
->ts
.type
== BT_CLASS
)
5185 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5186 tmp
= gfc_get_symbol_decl (vtab
);
5187 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5188 ptr
= gfc_class_vptr_get (parmse
.expr
);
5189 gfc_add_modify (&block
, ptr
,
5190 fold_convert (TREE_TYPE (ptr
), tmp
));
5191 gfc_add_expr_to_block (&block
, tmp
);
5194 if (fsym
->attr
.optional
5195 && e
->expr_type
== EXPR_VARIABLE
5196 && e
->symtree
->n
.sym
->attr
.optional
)
5198 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5200 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5201 gfc_finish_block (&block
),
5202 build_empty_stmt (input_location
));
5205 tmp
= gfc_finish_block (&block
);
5207 gfc_add_expr_to_block (&se
->pre
, tmp
);
5210 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5211 || fsym
->ts
.type
== BT_ASSUMED
)
5212 && e
->ts
.type
== BT_CLASS
5213 && !CLASS_DATA (e
)->attr
.dimension
5214 && !CLASS_DATA (e
)->attr
.codimension
)
5215 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5217 /* Wrap scalar variable in a descriptor. We need to convert
5218 the address of a pointer back to the pointer itself before,
5219 we can assign it to the data field. */
5221 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5222 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5225 if (TREE_CODE (tmp
) == ADDR_EXPR
5226 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5227 tmp
= TREE_OPERAND (tmp
, 0);
5228 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5230 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5233 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5234 && ((fsym
->attr
.pointer
5235 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5236 || (fsym
->attr
.proc_pointer
5237 && !(e
->expr_type
== EXPR_VARIABLE
5238 && e
->symtree
->n
.sym
->attr
.dummy
))
5239 || (fsym
->attr
.proc_pointer
5240 && e
->expr_type
== EXPR_VARIABLE
5241 && gfc_is_proc_ptr_comp (e
))
5242 || (fsym
->attr
.allocatable
5243 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5245 /* Scalar pointer dummy args require an extra level of
5246 indirection. The null pointer already contains
5247 this level of indirection. */
5248 parm_kind
= SCALAR_POINTER
;
5249 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5253 else if (e
->ts
.type
== BT_CLASS
5254 && fsym
&& fsym
->ts
.type
== BT_CLASS
5255 && (CLASS_DATA (fsym
)->attr
.dimension
5256 || CLASS_DATA (fsym
)->attr
.codimension
))
5258 /* Pass a class array. */
5259 parmse
.use_offset
= 1;
5260 gfc_conv_expr_descriptor (&parmse
, e
);
5262 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5263 allocated on entry, it must be deallocated. */
5264 if (fsym
->attr
.intent
== INTENT_OUT
5265 && CLASS_DATA (fsym
)->attr
.allocatable
)
5270 gfc_init_block (&block
);
5272 ptr
= gfc_class_data_get (ptr
);
5274 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5275 NULL_TREE
, NULL_TREE
,
5278 gfc_add_expr_to_block (&block
, tmp
);
5279 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5280 void_type_node
, ptr
,
5282 gfc_add_expr_to_block (&block
, tmp
);
5283 gfc_reset_vptr (&block
, e
);
5285 if (fsym
->attr
.optional
5286 && e
->expr_type
== EXPR_VARIABLE
5288 || (e
->ref
->type
== REF_ARRAY
5289 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5290 && e
->symtree
->n
.sym
->attr
.optional
)
5292 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5294 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5295 gfc_finish_block (&block
),
5296 build_empty_stmt (input_location
));
5299 tmp
= gfc_finish_block (&block
);
5301 gfc_add_expr_to_block (&se
->pre
, tmp
);
5304 /* The conversion does not repackage the reference to a class
5305 array - _data descriptor. */
5306 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5307 fsym
->attr
.intent
!= INTENT_IN
5308 && (CLASS_DATA (fsym
)->attr
.class_pointer
5309 || CLASS_DATA (fsym
)->attr
.allocatable
),
5311 && e
->expr_type
== EXPR_VARIABLE
5312 && e
->symtree
->n
.sym
->attr
.optional
,
5313 CLASS_DATA (fsym
)->attr
.class_pointer
5314 || CLASS_DATA (fsym
)->attr
.allocatable
);
5318 /* If the argument is a function call that may not create
5319 a temporary for the result, we have to check that we
5320 can do it, i.e. that there is no alias between this
5321 argument and another one. */
5322 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5328 intent
= fsym
->attr
.intent
;
5330 intent
= INTENT_UNKNOWN
;
5332 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5334 parmse
.force_tmp
= 1;
5336 iarg
= e
->value
.function
.actual
->expr
;
5338 /* Temporary needed if aliasing due to host association. */
5339 if (sym
->attr
.contained
5341 && !sym
->attr
.implicit_pure
5342 && !sym
->attr
.use_assoc
5343 && iarg
->expr_type
== EXPR_VARIABLE
5344 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5345 parmse
.force_tmp
= 1;
5347 /* Ditto within module. */
5348 if (sym
->attr
.use_assoc
5350 && !sym
->attr
.implicit_pure
5351 && iarg
->expr_type
== EXPR_VARIABLE
5352 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5353 parmse
.force_tmp
= 1;
5356 if (e
->expr_type
== EXPR_VARIABLE
5357 && is_subref_array (e
))
5358 /* The actual argument is a component reference to an
5359 array of derived types. In this case, the argument
5360 is converted to a temporary, which is passed and then
5361 written back after the procedure call. */
5362 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5363 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5364 fsym
&& fsym
->attr
.pointer
);
5365 else if (gfc_is_class_array_ref (e
, NULL
)
5366 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5367 /* The actual argument is a component reference to an
5368 array of derived types. In this case, the argument
5369 is converted to a temporary, which is passed and then
5370 written back after the procedure call.
5371 OOP-TODO: Insert code so that if the dynamic type is
5372 the same as the declared type, copy-in/copy-out does
5374 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5375 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5376 fsym
&& fsym
->attr
.pointer
);
5378 else if (gfc_is_alloc_class_array_function (e
)
5379 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5380 /* See previous comment. For function actual argument,
5381 the write out is not needed so the intent is set as
5384 e
->must_finalize
= 1;
5385 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5387 fsym
&& fsym
->attr
.pointer
);
5390 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5393 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5394 allocated on entry, it must be deallocated. */
5395 if (fsym
&& fsym
->attr
.allocatable
5396 && fsym
->attr
.intent
== INTENT_OUT
)
5398 tmp
= build_fold_indirect_ref_loc (input_location
,
5400 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5401 if (fsym
->attr
.optional
5402 && e
->expr_type
== EXPR_VARIABLE
5403 && e
->symtree
->n
.sym
->attr
.optional
)
5404 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5406 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5407 tmp
, build_empty_stmt (input_location
));
5408 gfc_add_expr_to_block (&se
->pre
, tmp
);
5413 /* The case with fsym->attr.optional is that of a user subroutine
5414 with an interface indicating an optional argument. When we call
5415 an intrinsic subroutine, however, fsym is NULL, but we might still
5416 have an optional argument, so we proceed to the substitution
5418 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5420 /* If an optional argument is itself an optional dummy argument,
5421 check its presence and substitute a null if absent. This is
5422 only needed when passing an array to an elemental procedure
5423 as then array elements are accessed - or no NULL pointer is
5424 allowed and a "1" or "0" should be passed if not present.
5425 When passing a non-array-descriptor full array to a
5426 non-array-descriptor dummy, no check is needed. For
5427 array-descriptor actual to array-descriptor dummy, see
5428 PR 41911 for why a check has to be inserted.
5429 fsym == NULL is checked as intrinsics required the descriptor
5430 but do not always set fsym. */
5431 if (e
->expr_type
== EXPR_VARIABLE
5432 && e
->symtree
->n
.sym
->attr
.optional
5433 && ((e
->rank
!= 0 && elemental_proc
)
5434 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5438 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5439 || fsym
->as
->type
== AS_ASSUMED_RANK
5440 || fsym
->as
->type
== AS_DEFERRED
))))))
5441 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5442 e
->representation
.length
);
5447 /* Obtain the character length of an assumed character length
5448 length procedure from the typespec. */
5449 if (fsym
->ts
.type
== BT_CHARACTER
5450 && parmse
.string_length
== NULL_TREE
5451 && e
->ts
.type
== BT_PROCEDURE
5452 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5453 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5454 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5456 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5457 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5461 if (fsym
&& need_interface_mapping
&& e
)
5462 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5464 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5465 gfc_add_block_to_block (&post
, &parmse
.post
);
5467 /* Allocated allocatable components of derived types must be
5468 deallocated for non-variable scalars, array arguments to elemental
5469 procedures, and array arguments with descriptor to non-elemental
5470 procedures. As bounds information for descriptorless arrays is no
5471 longer available here, they are dealt with in trans-array.c
5472 (gfc_conv_array_parameter). */
5473 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5474 && e
->ts
.u
.derived
->attr
.alloc_comp
5475 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5476 && !expr_may_alias_variables (e
, elemental_proc
))
5479 /* It is known the e returns a structure type with at least one
5480 allocatable component. When e is a function, ensure that the
5481 function is called once only by using a temporary variable. */
5482 if (!DECL_P (parmse
.expr
))
5483 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5484 parmse
.expr
, &se
->pre
);
5486 if (fsym
&& fsym
->attr
.value
)
5489 tmp
= build_fold_indirect_ref_loc (input_location
,
5492 parm_rank
= e
->rank
;
5500 case (SCALAR_POINTER
):
5501 tmp
= build_fold_indirect_ref_loc (input_location
,
5506 if (e
->expr_type
== EXPR_OP
5507 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5508 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5511 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5512 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5513 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5516 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5518 /* The derived type is passed to gfc_deallocate_alloc_comp.
5519 Therefore, class actuals can handled correctly but derived
5520 types passed to class formals need the _data component. */
5521 tmp
= gfc_class_data_get (tmp
);
5522 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5523 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5526 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5528 gfc_add_expr_to_block (&se
->post
, tmp
);
5531 /* Add argument checking of passing an unallocated/NULL actual to
5532 a nonallocatable/nonpointer dummy. */
5534 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5536 symbol_attribute attr
;
5540 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5541 attr
= gfc_expr_attr (e
);
5543 goto end_pointer_check
;
5545 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5546 allocatable to an optional dummy, cf. 12.5.2.12. */
5547 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5548 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5549 goto end_pointer_check
;
5553 /* If the actual argument is an optional pointer/allocatable and
5554 the formal argument takes an nonpointer optional value,
5555 it is invalid to pass a non-present argument on, even
5556 though there is no technical reason for this in gfortran.
5557 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5558 tree present
, null_ptr
, type
;
5560 if (attr
.allocatable
5561 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5562 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5563 "allocated or not present",
5564 e
->symtree
->n
.sym
->name
);
5565 else if (attr
.pointer
5566 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5567 msg
= xasprintf ("Pointer actual argument '%s' is not "
5568 "associated or not present",
5569 e
->symtree
->n
.sym
->name
);
5570 else if (attr
.proc_pointer
5571 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5572 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5573 "associated or not present",
5574 e
->symtree
->n
.sym
->name
);
5576 goto end_pointer_check
;
5578 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5579 type
= TREE_TYPE (present
);
5580 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5581 boolean_type_node
, present
,
5583 null_pointer_node
));
5584 type
= TREE_TYPE (parmse
.expr
);
5585 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5586 boolean_type_node
, parmse
.expr
,
5588 null_pointer_node
));
5589 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5590 boolean_type_node
, present
, null_ptr
);
5594 if (attr
.allocatable
5595 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5596 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5597 "allocated", e
->symtree
->n
.sym
->name
);
5598 else if (attr
.pointer
5599 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5600 msg
= xasprintf ("Pointer actual argument '%s' is not "
5601 "associated", e
->symtree
->n
.sym
->name
);
5602 else if (attr
.proc_pointer
5603 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5604 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5605 "associated", e
->symtree
->n
.sym
->name
);
5607 goto end_pointer_check
;
5611 /* If the argument is passed by value, we need to strip the
5613 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5614 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5616 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5617 boolean_type_node
, tmp
,
5618 fold_convert (TREE_TYPE (tmp
),
5619 null_pointer_node
));
5622 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5628 /* Deferred length dummies pass the character length by reference
5629 so that the value can be returned. */
5630 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5632 if (INDIRECT_REF_P (parmse
.string_length
))
5633 /* In chains of functions/procedure calls the string_length already
5634 is a pointer to the variable holding the length. Therefore
5635 remove the deref on call. */
5636 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5639 tmp
= parmse
.string_length
;
5640 if (TREE_CODE (tmp
) != VAR_DECL
5641 && TREE_CODE (tmp
) != COMPONENT_REF
)
5642 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5643 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5647 /* Character strings are passed as two parameters, a length and a
5648 pointer - except for Bind(c) which only passes the pointer.
5649 An unlimited polymorphic formal argument likewise does not
5651 if (parmse
.string_length
!= NULL_TREE
5652 && !sym
->attr
.is_bind_c
5653 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5654 vec_safe_push (stringargs
, parmse
.string_length
);
5656 /* When calling __copy for character expressions to unlimited
5657 polymorphic entities, the dst argument needs a string length. */
5658 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5659 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5660 && arg
->next
&& arg
->next
->expr
5661 && (arg
->next
->expr
->ts
.type
== BT_DERIVED
5662 || arg
->next
->expr
->ts
.type
== BT_CLASS
)
5663 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5664 vec_safe_push (stringargs
, parmse
.string_length
);
5666 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5667 pass the token and the offset as additional arguments. */
5668 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5669 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5670 && !fsym
->attr
.allocatable
)
5671 || (fsym
->ts
.type
== BT_CLASS
5672 && CLASS_DATA (fsym
)->attr
.codimension
5673 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5675 /* Token and offset. */
5676 vec_safe_push (stringargs
, null_pointer_node
);
5677 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5678 gcc_assert (fsym
->attr
.optional
);
5680 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5681 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5682 && !fsym
->attr
.allocatable
)
5683 || (fsym
->ts
.type
== BT_CLASS
5684 && CLASS_DATA (fsym
)->attr
.codimension
5685 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5687 tree caf_decl
, caf_type
;
5690 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5691 caf_type
= TREE_TYPE (caf_decl
);
5693 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5694 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5695 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5696 tmp
= gfc_conv_descriptor_token (caf_decl
);
5697 else if (DECL_LANG_SPECIFIC (caf_decl
)
5698 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5699 tmp
= GFC_DECL_TOKEN (caf_decl
);
5702 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5703 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5704 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5707 vec_safe_push (stringargs
, tmp
);
5709 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5710 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5711 offset
= build_int_cst (gfc_array_index_type
, 0);
5712 else if (DECL_LANG_SPECIFIC (caf_decl
)
5713 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5714 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5715 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5716 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5718 offset
= build_int_cst (gfc_array_index_type
, 0);
5720 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5721 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5724 gcc_assert (POINTER_TYPE_P (caf_type
));
5728 tmp2
= fsym
->ts
.type
== BT_CLASS
5729 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5730 if ((fsym
->ts
.type
!= BT_CLASS
5731 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5732 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5733 || (fsym
->ts
.type
== BT_CLASS
5734 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5735 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5737 if (fsym
->ts
.type
== BT_CLASS
)
5738 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5741 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5742 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5744 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5745 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5747 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5748 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5751 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5754 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5755 gfc_array_index_type
,
5756 fold_convert (gfc_array_index_type
, tmp2
),
5757 fold_convert (gfc_array_index_type
, tmp
));
5758 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5759 gfc_array_index_type
, offset
, tmp
);
5761 vec_safe_push (stringargs
, offset
);
5764 vec_safe_push (arglist
, parmse
.expr
);
5766 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5773 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5774 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5775 else if (ts
.type
== BT_CHARACTER
)
5777 if (ts
.u
.cl
->length
== NULL
)
5779 /* Assumed character length results are not allowed by 5.1.1.5 of the
5780 standard and are trapped in resolve.c; except in the case of SPREAD
5781 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5782 we take the character length of the first argument for the result.
5783 For dummies, we have to look through the formal argument list for
5784 this function and use the character length found there.*/
5786 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5787 else if (!sym
->attr
.dummy
)
5788 cl
.backend_decl
= (*stringargs
)[0];
5791 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5792 for (; formal
; formal
= formal
->next
)
5793 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5794 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5796 len
= cl
.backend_decl
;
5802 /* Calculate the length of the returned string. */
5803 gfc_init_se (&parmse
, NULL
);
5804 if (need_interface_mapping
)
5805 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5807 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5808 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5809 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5811 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5812 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5813 gfc_charlen_type_node
, tmp
,
5814 build_int_cst (gfc_charlen_type_node
, 0));
5815 cl
.backend_decl
= tmp
;
5818 /* Set up a charlen structure for it. */
5823 len
= cl
.backend_decl
;
5826 byref
= (comp
&& (comp
->attr
.dimension
5827 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5828 || (!comp
&& gfc_return_by_reference (sym
));
5831 if (se
->direct_byref
)
5833 /* Sometimes, too much indirection can be applied; e.g. for
5834 function_result = array_valued_recursive_function. */
5835 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5836 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5837 && GFC_DESCRIPTOR_TYPE_P
5838 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5839 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5842 /* If the lhs of an assignment x = f(..) is allocatable and
5843 f2003 is allowed, we must do the automatic reallocation.
5844 TODO - deal with intrinsics, without using a temporary. */
5845 if (flag_realloc_lhs
5846 && se
->ss
&& se
->ss
->loop_chain
5847 && se
->ss
->loop_chain
->is_alloc_lhs
5848 && !expr
->value
.function
.isym
5849 && sym
->result
->as
!= NULL
)
5851 /* Evaluate the bounds of the result, if known. */
5852 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5855 /* Perform the automatic reallocation. */
5856 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5858 gfc_add_expr_to_block (&se
->pre
, tmp
);
5860 /* Pass the temporary as the first argument. */
5861 result
= info
->descriptor
;
5864 result
= build_fold_indirect_ref_loc (input_location
,
5866 vec_safe_push (retargs
, se
->expr
);
5868 else if (comp
&& comp
->attr
.dimension
)
5870 gcc_assert (se
->loop
&& info
);
5872 /* Set the type of the array. */
5873 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5874 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5876 /* Evaluate the bounds of the result, if known. */
5877 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5879 /* If the lhs of an assignment x = f(..) is allocatable and
5880 f2003 is allowed, we must not generate the function call
5881 here but should just send back the results of the mapping.
5882 This is signalled by the function ss being flagged. */
5883 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5885 gfc_free_interface_mapping (&mapping
);
5886 return has_alternate_specifier
;
5889 /* Create a temporary to store the result. In case the function
5890 returns a pointer, the temporary will be a shallow copy and
5891 mustn't be deallocated. */
5892 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5893 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5894 tmp
, NULL_TREE
, false,
5895 !comp
->attr
.pointer
, callee_alloc
,
5896 &se
->ss
->info
->expr
->where
);
5898 /* Pass the temporary as the first argument. */
5899 result
= info
->descriptor
;
5900 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5901 vec_safe_push (retargs
, tmp
);
5903 else if (!comp
&& sym
->result
->attr
.dimension
)
5905 gcc_assert (se
->loop
&& info
);
5907 /* Set the type of the array. */
5908 tmp
= gfc_typenode_for_spec (&ts
);
5909 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5911 /* Evaluate the bounds of the result, if known. */
5912 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5914 /* If the lhs of an assignment x = f(..) is allocatable and
5915 f2003 is allowed, we must not generate the function call
5916 here but should just send back the results of the mapping.
5917 This is signalled by the function ss being flagged. */
5918 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5920 gfc_free_interface_mapping (&mapping
);
5921 return has_alternate_specifier
;
5924 /* Create a temporary to store the result. In case the function
5925 returns a pointer, the temporary will be a shallow copy and
5926 mustn't be deallocated. */
5927 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5928 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5929 tmp
, NULL_TREE
, false,
5930 !sym
->attr
.pointer
, callee_alloc
,
5931 &se
->ss
->info
->expr
->where
);
5933 /* Pass the temporary as the first argument. */
5934 result
= info
->descriptor
;
5935 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5936 vec_safe_push (retargs
, tmp
);
5938 else if (ts
.type
== BT_CHARACTER
)
5940 /* Pass the string length. */
5941 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5942 type
= build_pointer_type (type
);
5944 /* Return an address to a char[0:len-1]* temporary for
5945 character pointers. */
5946 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5947 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5949 var
= gfc_create_var (type
, "pstr");
5951 if ((!comp
&& sym
->attr
.allocatable
)
5952 || (comp
&& comp
->attr
.allocatable
))
5954 gfc_add_modify (&se
->pre
, var
,
5955 fold_convert (TREE_TYPE (var
),
5956 null_pointer_node
));
5957 tmp
= gfc_call_free (var
);
5958 gfc_add_expr_to_block (&se
->post
, tmp
);
5961 /* Provide an address expression for the function arguments. */
5962 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5965 var
= gfc_conv_string_tmp (se
, type
, len
);
5967 vec_safe_push (retargs
, var
);
5971 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5973 type
= gfc_get_complex_type (ts
.kind
);
5974 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5975 vec_safe_push (retargs
, var
);
5978 /* Add the string length to the argument list. */
5979 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5982 if (TREE_CODE (tmp
) != VAR_DECL
)
5983 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5984 TREE_STATIC (tmp
) = 1;
5985 gfc_add_modify (&se
->pre
, tmp
,
5986 build_int_cst (TREE_TYPE (tmp
), 0));
5987 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5988 vec_safe_push (retargs
, tmp
);
5990 else if (ts
.type
== BT_CHARACTER
)
5991 vec_safe_push (retargs
, len
);
5993 gfc_free_interface_mapping (&mapping
);
5995 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5996 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5997 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5998 vec_safe_reserve (retargs
, arglen
);
6000 /* Add the return arguments. */
6001 vec_safe_splice (retargs
, arglist
);
6003 /* Add the hidden present status for optional+value to the arguments. */
6004 vec_safe_splice (retargs
, optionalargs
);
6006 /* Add the hidden string length parameters to the arguments. */
6007 vec_safe_splice (retargs
, stringargs
);
6009 /* We may want to append extra arguments here. This is used e.g. for
6010 calls to libgfortran_matmul_??, which need extra information. */
6011 vec_safe_splice (retargs
, append_args
);
6015 /* Generate the actual call. */
6016 if (base_object
== NULL_TREE
)
6017 conv_function_val (se
, sym
, expr
);
6019 conv_base_obj_fcn_val (se
, base_object
, expr
);
6021 /* If there are alternate return labels, function type should be
6022 integer. Can't modify the type in place though, since it can be shared
6023 with other functions. For dummy arguments, the typing is done to
6024 this result, even if it has to be repeated for each call. */
6025 if (has_alternate_specifier
6026 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
6028 if (!sym
->attr
.dummy
)
6030 TREE_TYPE (sym
->backend_decl
)
6031 = build_function_type (integer_type_node
,
6032 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
6033 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
6036 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
6039 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
6040 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6042 /* Allocatable scalar function results must be freed and nullified
6043 after use. This necessitates the creation of a temporary to
6044 hold the result to prevent duplicate calls. */
6045 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6046 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6048 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6049 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6051 tmp
= gfc_call_free (tmp
);
6052 gfc_add_expr_to_block (&post
, tmp
);
6053 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6056 /* If we have a pointer function, but we don't want a pointer, e.g.
6059 where f is pointer valued, we have to dereference the result. */
6060 if (!se
->want_pointer
&& !byref
6061 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6062 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6063 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6065 /* f2c calling conventions require a scalar default real function to
6066 return a double precision result. Convert this back to default
6067 real. We only care about the cases that can happen in Fortran 77.
6069 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6070 && sym
->ts
.kind
== gfc_default_real_kind
6071 && !sym
->attr
.always_explicit
)
6072 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6074 /* A pure function may still have side-effects - it may modify its
6076 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6078 if (!sym
->attr
.pure
)
6079 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6084 /* Add the function call to the pre chain. There is no expression. */
6085 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6086 se
->expr
= NULL_TREE
;
6088 if (!se
->direct_byref
)
6090 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6092 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6094 /* Check the data pointer hasn't been modified. This would
6095 happen in a function returning a pointer. */
6096 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6097 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6100 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6103 se
->expr
= info
->descriptor
;
6104 /* Bundle in the string length. */
6105 se
->string_length
= len
;
6107 else if (ts
.type
== BT_CHARACTER
)
6109 /* Dereference for character pointer results. */
6110 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6111 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6112 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6116 se
->string_length
= len
;
6120 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6121 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6126 /* Follow the function call with the argument post block. */
6129 gfc_add_block_to_block (&se
->pre
, &post
);
6131 /* Transformational functions of derived types with allocatable
6132 components must have the result allocatable components copied. */
6133 arg
= expr
->value
.function
.actual
;
6134 if (result
&& arg
&& expr
->rank
6135 && expr
->value
.function
.isym
6136 && expr
->value
.function
.isym
->transformational
6137 && arg
->expr
->ts
.type
== BT_DERIVED
6138 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6141 /* Copy the allocatable components. We have to use a
6142 temporary here to prevent source allocatable components
6143 from being corrupted. */
6144 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6145 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6146 result
, tmp2
, expr
->rank
);
6147 gfc_add_expr_to_block (&se
->pre
, tmp
);
6148 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6150 gfc_add_expr_to_block (&se
->pre
, tmp
);
6152 /* Finally free the temporary's data field. */
6153 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6154 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6155 NULL_TREE
, NULL_TREE
, true,
6157 gfc_add_expr_to_block (&se
->pre
, tmp
);
6162 /* For a function with a class array result, save the result as
6163 a temporary, set the info fields needed by the scalarizer and
6164 call the finalization function of the temporary. Note that the
6165 nullification of allocatable components needed by the result
6166 is done in gfc_trans_assignment_1. */
6167 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6168 && se
->ss
&& se
->ss
->loop
)
6169 || gfc_is_alloc_class_scalar_function (expr
))
6170 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6171 && expr
->must_finalize
)
6176 if (se
->ss
&& se
->ss
->loop
)
6178 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6179 tmp
= gfc_class_data_get (se
->expr
);
6180 info
->descriptor
= tmp
;
6181 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6182 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6183 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6185 tree dim
= gfc_rank_cst
[n
];
6186 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6187 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6192 /* TODO Eliminate the doubling of temporaries. This
6193 one is necessary to ensure no memory leakage. */
6194 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6195 tmp
= gfc_class_data_get (se
->expr
);
6196 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6197 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6200 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6201 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6204 fold_convert (TREE_TYPE (final_fndecl
),
6205 null_pointer_node
));
6206 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6208 tmp
= build_call_expr_loc (input_location
,
6210 gfc_build_addr_expr (NULL
, tmp
),
6211 gfc_class_vtab_size_get (se
->expr
),
6212 boolean_false_node
);
6213 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6214 void_type_node
, is_final
, tmp
,
6215 build_empty_stmt (input_location
));
6217 if (se
->ss
&& se
->ss
->loop
)
6219 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6220 tmp
= gfc_call_free (info
->data
);
6221 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6225 gfc_add_expr_to_block (&se
->post
, tmp
);
6226 tmp
= gfc_class_data_get (se
->expr
);
6227 tmp
= gfc_call_free (tmp
);
6228 gfc_add_expr_to_block (&se
->post
, tmp
);
6230 expr
->must_finalize
= 0;
6233 gfc_add_block_to_block (&se
->post
, &post
);
6236 return has_alternate_specifier
;
6240 /* Fill a character string with spaces. */
6243 fill_with_spaces (tree start
, tree type
, tree size
)
6245 stmtblock_t block
, loop
;
6246 tree i
, el
, exit_label
, cond
, tmp
;
6248 /* For a simple char type, we can call memset(). */
6249 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6250 return build_call_expr_loc (input_location
,
6251 builtin_decl_explicit (BUILT_IN_MEMSET
),
6253 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6254 lang_hooks
.to_target_charset (' ')),
6257 /* Otherwise, we use a loop:
6258 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6262 /* Initialize variables. */
6263 gfc_init_block (&block
);
6264 i
= gfc_create_var (sizetype
, "i");
6265 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6266 el
= gfc_create_var (build_pointer_type (type
), "el");
6267 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6268 exit_label
= gfc_build_label_decl (NULL_TREE
);
6269 TREE_USED (exit_label
) = 1;
6273 gfc_init_block (&loop
);
6275 /* Exit condition. */
6276 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6277 build_zero_cst (sizetype
));
6278 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6279 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6280 build_empty_stmt (input_location
));
6281 gfc_add_expr_to_block (&loop
, tmp
);
6284 gfc_add_modify (&loop
,
6285 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6286 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6288 /* Increment loop variables. */
6289 gfc_add_modify (&loop
, i
,
6290 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6291 TYPE_SIZE_UNIT (type
)));
6292 gfc_add_modify (&loop
, el
,
6293 fold_build_pointer_plus_loc (input_location
,
6294 el
, TYPE_SIZE_UNIT (type
)));
6296 /* Making the loop... actually loop! */
6297 tmp
= gfc_finish_block (&loop
);
6298 tmp
= build1_v (LOOP_EXPR
, tmp
);
6299 gfc_add_expr_to_block (&block
, tmp
);
6301 /* The exit label. */
6302 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6303 gfc_add_expr_to_block (&block
, tmp
);
6306 return gfc_finish_block (&block
);
6310 /* Generate code to copy a string. */
6313 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6314 int dkind
, tree slength
, tree src
, int skind
)
6316 tree tmp
, dlen
, slen
;
6325 stmtblock_t tempblock
;
6327 gcc_assert (dkind
== skind
);
6329 if (slength
!= NULL_TREE
)
6331 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6332 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6336 slen
= build_int_cst (size_type_node
, 1);
6340 if (dlength
!= NULL_TREE
)
6342 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6343 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6347 dlen
= build_int_cst (size_type_node
, 1);
6351 /* Assign directly if the types are compatible. */
6352 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6353 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6355 gfc_add_modify (block
, dsc
, ssc
);
6359 /* Do nothing if the destination length is zero. */
6360 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6361 build_int_cst (size_type_node
, 0));
6363 /* The following code was previously in _gfortran_copy_string:
6365 // The two strings may overlap so we use memmove.
6367 copy_string (GFC_INTEGER_4 destlen, char * dest,
6368 GFC_INTEGER_4 srclen, const char * src)
6370 if (srclen >= destlen)
6372 // This will truncate if too long.
6373 memmove (dest, src, destlen);
6377 memmove (dest, src, srclen);
6379 memset (&dest[srclen], ' ', destlen - srclen);
6383 We're now doing it here for better optimization, but the logic
6386 /* For non-default character kinds, we have to multiply the string
6387 length by the base type size. */
6388 chartype
= gfc_get_char_type (dkind
);
6389 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6390 fold_convert (size_type_node
, slen
),
6391 fold_convert (size_type_node
,
6392 TYPE_SIZE_UNIT (chartype
)));
6393 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6394 fold_convert (size_type_node
, dlen
),
6395 fold_convert (size_type_node
,
6396 TYPE_SIZE_UNIT (chartype
)));
6398 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6399 dest
= fold_convert (pvoid_type_node
, dest
);
6401 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6403 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6404 src
= fold_convert (pvoid_type_node
, src
);
6406 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6408 /* Truncate string if source is too long. */
6409 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6411 tmp2
= build_call_expr_loc (input_location
,
6412 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6413 3, dest
, src
, dlen
);
6415 /* Else copy and pad with spaces. */
6416 tmp3
= build_call_expr_loc (input_location
,
6417 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6418 3, dest
, src
, slen
);
6420 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6421 tmp4
= fill_with_spaces (tmp4
, chartype
,
6422 fold_build2_loc (input_location
, MINUS_EXPR
,
6423 TREE_TYPE(dlen
), dlen
, slen
));
6425 gfc_init_block (&tempblock
);
6426 gfc_add_expr_to_block (&tempblock
, tmp3
);
6427 gfc_add_expr_to_block (&tempblock
, tmp4
);
6428 tmp3
= gfc_finish_block (&tempblock
);
6430 /* The whole copy_string function is there. */
6431 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6433 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6434 build_empty_stmt (input_location
));
6435 gfc_add_expr_to_block (block
, tmp
);
6439 /* Translate a statement function.
6440 The value of a statement function reference is obtained by evaluating the
6441 expression using the values of the actual arguments for the values of the
6442 corresponding dummy arguments. */
6445 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6449 gfc_formal_arglist
*fargs
;
6450 gfc_actual_arglist
*args
;
6453 gfc_saved_var
*saved_vars
;
6459 sym
= expr
->symtree
->n
.sym
;
6460 args
= expr
->value
.function
.actual
;
6461 gfc_init_se (&lse
, NULL
);
6462 gfc_init_se (&rse
, NULL
);
6465 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6467 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6468 temp_vars
= XCNEWVEC (tree
, n
);
6470 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6471 fargs
= fargs
->next
, n
++)
6473 /* Each dummy shall be specified, explicitly or implicitly, to be
6475 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6478 if (fsym
->ts
.type
== BT_CHARACTER
)
6480 /* Copy string arguments. */
6483 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6484 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6486 /* Create a temporary to hold the value. */
6487 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6488 fsym
->ts
.u
.cl
->backend_decl
6489 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6491 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6492 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6494 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6496 gfc_conv_expr (&rse
, args
->expr
);
6497 gfc_conv_string_parameter (&rse
);
6498 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6499 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6501 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6502 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6503 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6504 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6508 /* For everything else, just evaluate the expression. */
6510 /* Create a temporary to hold the value. */
6511 type
= gfc_typenode_for_spec (&fsym
->ts
);
6512 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6514 gfc_conv_expr (&lse
, args
->expr
);
6516 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6517 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6518 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6524 /* Use the temporary variables in place of the real ones. */
6525 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6526 fargs
= fargs
->next
, n
++)
6527 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6529 gfc_conv_expr (se
, sym
->value
);
6531 if (sym
->ts
.type
== BT_CHARACTER
)
6533 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6535 /* Force the expression to the correct length. */
6536 if (!INTEGER_CST_P (se
->string_length
)
6537 || tree_int_cst_lt (se
->string_length
,
6538 sym
->ts
.u
.cl
->backend_decl
))
6540 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6541 tmp
= gfc_create_var (type
, sym
->name
);
6542 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6543 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6544 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6548 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6551 /* Restore the original variables. */
6552 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6553 fargs
= fargs
->next
, n
++)
6554 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6560 /* Translate a function expression. */
6563 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6567 if (expr
->value
.function
.isym
)
6569 gfc_conv_intrinsic_function (se
, expr
);
6573 /* expr.value.function.esym is the resolved (specific) function symbol for
6574 most functions. However this isn't set for dummy procedures. */
6575 sym
= expr
->value
.function
.esym
;
6577 sym
= expr
->symtree
->n
.sym
;
6579 /* The IEEE_ARITHMETIC functions are caught here. */
6580 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6581 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6584 /* We distinguish statement functions from general functions to improve
6585 runtime performance. */
6586 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6588 gfc_conv_statement_function (se
, expr
);
6592 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6597 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6600 is_zero_initializer_p (gfc_expr
* expr
)
6602 if (expr
->expr_type
!= EXPR_CONSTANT
)
6605 /* We ignore constants with prescribed memory representations for now. */
6606 if (expr
->representation
.string
)
6609 switch (expr
->ts
.type
)
6612 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6615 return mpfr_zero_p (expr
->value
.real
)
6616 && MPFR_SIGN (expr
->value
.real
) >= 0;
6619 return expr
->value
.logical
== 0;
6622 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6623 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6624 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6625 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6635 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6640 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6641 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6643 gfc_conv_tmp_array_ref (se
);
6647 /* Build a static initializer. EXPR is the expression for the initial value.
6648 The other parameters describe the variable of the component being
6649 initialized. EXPR may be null. */
6652 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6653 bool array
, bool pointer
, bool procptr
)
6657 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6658 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6659 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6660 return build_constructor (type
, NULL
);
6662 if (!(expr
|| pointer
|| procptr
))
6665 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6666 (these are the only two iso_c_binding derived types that can be
6667 used as initialization expressions). If so, we need to modify
6668 the 'expr' to be that for a (void *). */
6669 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6670 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6672 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6674 /* The derived symbol has already been converted to a (void *). Use
6676 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6677 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6679 gfc_init_se (&se
, NULL
);
6680 gfc_conv_constant (&se
, expr
);
6681 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6685 if (array
&& !procptr
)
6688 /* Arrays need special handling. */
6690 ctor
= gfc_build_null_descriptor (type
);
6691 /* Special case assigning an array to zero. */
6692 else if (is_zero_initializer_p (expr
))
6693 ctor
= build_constructor (type
, NULL
);
6695 ctor
= gfc_conv_array_initializer (type
, expr
);
6696 TREE_STATIC (ctor
) = 1;
6699 else if (pointer
|| procptr
)
6701 if (ts
->type
== BT_CLASS
&& !procptr
)
6703 gfc_init_se (&se
, NULL
);
6704 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6705 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6706 TREE_STATIC (se
.expr
) = 1;
6709 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6710 return fold_convert (type
, null_pointer_node
);
6713 gfc_init_se (&se
, NULL
);
6714 se
.want_pointer
= 1;
6715 gfc_conv_expr (&se
, expr
);
6716 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6726 gfc_init_se (&se
, NULL
);
6727 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6728 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6730 gfc_conv_structure (&se
, expr
, 1);
6731 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6732 TREE_STATIC (se
.expr
) = 1;
6737 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6738 TREE_STATIC (ctor
) = 1;
6743 gfc_init_se (&se
, NULL
);
6744 gfc_conv_constant (&se
, expr
);
6745 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6752 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6758 gfc_array_info
*lss_array
;
6765 gfc_start_block (&block
);
6767 /* Initialize the scalarizer. */
6768 gfc_init_loopinfo (&loop
);
6770 gfc_init_se (&lse
, NULL
);
6771 gfc_init_se (&rse
, NULL
);
6774 rss
= gfc_walk_expr (expr
);
6775 if (rss
== gfc_ss_terminator
)
6776 /* The rhs is scalar. Add a ss for the expression. */
6777 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6779 /* Create a SS for the destination. */
6780 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6782 lss_array
= &lss
->info
->data
.array
;
6783 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6784 lss_array
->descriptor
= dest
;
6785 lss_array
->data
= gfc_conv_array_data (dest
);
6786 lss_array
->offset
= gfc_conv_array_offset (dest
);
6787 for (n
= 0; n
< cm
->as
->rank
; n
++)
6789 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6790 lss_array
->stride
[n
] = gfc_index_one_node
;
6792 mpz_init (lss_array
->shape
[n
]);
6793 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6794 cm
->as
->lower
[n
]->value
.integer
);
6795 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6798 /* Associate the SS with the loop. */
6799 gfc_add_ss_to_loop (&loop
, lss
);
6800 gfc_add_ss_to_loop (&loop
, rss
);
6802 /* Calculate the bounds of the scalarization. */
6803 gfc_conv_ss_startstride (&loop
);
6805 /* Setup the scalarizing loops. */
6806 gfc_conv_loop_setup (&loop
, &expr
->where
);
6808 /* Setup the gfc_se structures. */
6809 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6810 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6813 gfc_mark_ss_chain_used (rss
, 1);
6815 gfc_mark_ss_chain_used (lss
, 1);
6817 /* Start the scalarized loop body. */
6818 gfc_start_scalarized_body (&loop
, &body
);
6820 gfc_conv_tmp_array_ref (&lse
);
6821 if (cm
->ts
.type
== BT_CHARACTER
)
6822 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6824 gfc_conv_expr (&rse
, expr
);
6826 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6827 gfc_add_expr_to_block (&body
, tmp
);
6829 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6831 /* Generate the copying loops. */
6832 gfc_trans_scalarizing_loops (&loop
, &body
);
6834 /* Wrap the whole thing up. */
6835 gfc_add_block_to_block (&block
, &loop
.pre
);
6836 gfc_add_block_to_block (&block
, &loop
.post
);
6838 gcc_assert (lss_array
->shape
!= NULL
);
6839 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6840 gfc_cleanup_loop (&loop
);
6842 return gfc_finish_block (&block
);
6847 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6857 gfc_expr
*arg
= NULL
;
6859 gfc_start_block (&block
);
6860 gfc_init_se (&se
, NULL
);
6862 /* Get the descriptor for the expressions. */
6863 se
.want_pointer
= 0;
6864 gfc_conv_expr_descriptor (&se
, expr
);
6865 gfc_add_block_to_block (&block
, &se
.pre
);
6866 gfc_add_modify (&block
, dest
, se
.expr
);
6868 /* Deal with arrays of derived types with allocatable components. */
6869 if (gfc_bt_struct (cm
->ts
.type
)
6870 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6871 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6874 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6875 && CLASS_DATA(cm
)->attr
.allocatable
)
6877 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6878 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6883 tmp
= TREE_TYPE (dest
);
6884 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6885 tmp
, expr
->rank
, NULL_TREE
);
6889 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6890 TREE_TYPE(cm
->backend_decl
),
6891 cm
->as
->rank
, NULL_TREE
);
6893 gfc_add_expr_to_block (&block
, tmp
);
6894 gfc_add_block_to_block (&block
, &se
.post
);
6896 if (expr
->expr_type
!= EXPR_VARIABLE
)
6897 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6900 /* We need to know if the argument of a conversion function is a
6901 variable, so that the correct lower bound can be used. */
6902 if (expr
->expr_type
== EXPR_FUNCTION
6903 && expr
->value
.function
.isym
6904 && expr
->value
.function
.isym
->conversion
6905 && expr
->value
.function
.actual
->expr
6906 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6907 arg
= expr
->value
.function
.actual
->expr
;
6909 /* Obtain the array spec of full array references. */
6911 as
= gfc_get_full_arrayspec_from_expr (arg
);
6913 as
= gfc_get_full_arrayspec_from_expr (expr
);
6915 /* Shift the lbound and ubound of temporaries to being unity,
6916 rather than zero, based. Always calculate the offset. */
6917 offset
= gfc_conv_descriptor_offset_get (dest
);
6918 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6919 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6921 for (n
= 0; n
< expr
->rank
; n
++)
6926 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6927 TODO It looks as if gfc_conv_expr_descriptor should return
6928 the correct bounds and that the following should not be
6929 necessary. This would simplify gfc_conv_intrinsic_bound
6931 if (as
&& as
->lower
[n
])
6934 gfc_init_se (&lbse
, NULL
);
6935 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6936 gfc_add_block_to_block (&block
, &lbse
.pre
);
6937 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6941 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6942 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6946 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6949 lbound
= gfc_index_one_node
;
6951 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6953 /* Shift the bounds and set the offset accordingly. */
6954 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6955 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6956 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6957 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6959 gfc_conv_descriptor_ubound_set (&block
, dest
,
6960 gfc_rank_cst
[n
], tmp
);
6961 gfc_conv_descriptor_lbound_set (&block
, dest
,
6962 gfc_rank_cst
[n
], lbound
);
6964 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6965 gfc_conv_descriptor_lbound_get (dest
,
6967 gfc_conv_descriptor_stride_get (dest
,
6969 gfc_add_modify (&block
, tmp2
, tmp
);
6970 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6972 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6977 /* If a conversion expression has a null data pointer
6978 argument, nullify the allocatable component. */
6982 if (arg
->symtree
->n
.sym
->attr
.allocatable
6983 || arg
->symtree
->n
.sym
->attr
.pointer
)
6985 non_null_expr
= gfc_finish_block (&block
);
6986 gfc_start_block (&block
);
6987 gfc_conv_descriptor_data_set (&block
, dest
,
6989 null_expr
= gfc_finish_block (&block
);
6990 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6991 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6992 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6993 return build3_v (COND_EXPR
, tmp
,
6994 null_expr
, non_null_expr
);
6998 return gfc_finish_block (&block
);
7002 /* Allocate or reallocate scalar component, as necessary. */
7005 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
7015 tree lhs_cl_size
= NULL_TREE
;
7020 if (!expr2
|| expr2
->rank
)
7023 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7025 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7027 char name
[GFC_MAX_SYMBOL_LEN
+9];
7028 gfc_component
*strlen
;
7029 /* Use the rhs string length and the lhs element size. */
7030 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7031 if (!expr2
->ts
.u
.cl
->backend_decl
)
7033 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
7034 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
7037 size
= expr2
->ts
.u
.cl
->backend_decl
;
7039 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7041 sprintf (name
, "_%s_length", cm
->name
);
7042 strlen
= gfc_find_component (sym
, name
, true, true, NULL
);
7043 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7044 gfc_charlen_type_node
,
7045 TREE_OPERAND (comp
, 0),
7046 strlen
->backend_decl
, NULL_TREE
);
7048 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7049 tmp
= TYPE_SIZE_UNIT (tmp
);
7050 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7051 TREE_TYPE (tmp
), tmp
,
7052 fold_convert (TREE_TYPE (tmp
), size
));
7054 else if (cm
->ts
.type
== BT_CLASS
)
7056 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7057 if (expr2
->ts
.type
== BT_DERIVED
)
7059 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7060 size
= TYPE_SIZE_UNIT (tmp
);
7066 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7067 gfc_add_vptr_component (e2vtab
);
7068 gfc_add_size_component (e2vtab
);
7069 gfc_init_se (&se
, NULL
);
7070 gfc_conv_expr (&se
, e2vtab
);
7071 gfc_add_block_to_block (block
, &se
.pre
);
7072 size
= fold_convert (size_type_node
, se
.expr
);
7073 gfc_free_expr (e2vtab
);
7075 size_in_bytes
= size
;
7079 /* Otherwise use the length in bytes of the rhs. */
7080 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7081 size_in_bytes
= size
;
7084 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7085 size_in_bytes
, size_one_node
);
7087 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7089 tmp
= build_call_expr_loc (input_location
,
7090 builtin_decl_explicit (BUILT_IN_CALLOC
),
7091 2, build_one_cst (size_type_node
),
7093 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7094 gfc_add_modify (block
, comp
, tmp
);
7098 tmp
= build_call_expr_loc (input_location
,
7099 builtin_decl_explicit (BUILT_IN_MALLOC
),
7101 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7102 ptr
= gfc_class_data_get (comp
);
7105 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7106 gfc_add_modify (block
, ptr
, tmp
);
7109 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7110 /* Update the lhs character length. */
7111 gfc_add_modify (block
, lhs_cl_size
, size
);
7115 /* Assign a single component of a derived type constructor. */
7118 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7119 gfc_symbol
*sym
, bool init
)
7127 gfc_start_block (&block
);
7129 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7131 /* Only care about pointers here, not about allocatables. */
7132 gfc_init_se (&se
, NULL
);
7133 /* Pointer component. */
7134 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7135 && !cm
->attr
.proc_pointer
)
7137 /* Array pointer. */
7138 if (expr
->expr_type
== EXPR_NULL
)
7139 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7142 se
.direct_byref
= 1;
7144 gfc_conv_expr_descriptor (&se
, expr
);
7145 gfc_add_block_to_block (&block
, &se
.pre
);
7146 gfc_add_block_to_block (&block
, &se
.post
);
7151 /* Scalar pointers. */
7152 se
.want_pointer
= 1;
7153 gfc_conv_expr (&se
, expr
);
7154 gfc_add_block_to_block (&block
, &se
.pre
);
7156 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7157 && expr
->symtree
->n
.sym
->attr
.dummy
)
7158 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7160 gfc_add_modify (&block
, dest
,
7161 fold_convert (TREE_TYPE (dest
), se
.expr
));
7162 gfc_add_block_to_block (&block
, &se
.post
);
7165 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7167 /* NULL initialization for CLASS components. */
7168 tmp
= gfc_trans_structure_assign (dest
,
7169 gfc_class_initializer (&cm
->ts
, expr
),
7171 gfc_add_expr_to_block (&block
, tmp
);
7173 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7174 && !cm
->attr
.proc_pointer
)
7176 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7177 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7178 else if (cm
->attr
.allocatable
)
7180 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7181 gfc_add_expr_to_block (&block
, tmp
);
7185 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7186 gfc_add_expr_to_block (&block
, tmp
);
7189 else if (cm
->ts
.type
== BT_CLASS
7190 && CLASS_DATA (cm
)->attr
.dimension
7191 && CLASS_DATA (cm
)->attr
.allocatable
7192 && expr
->ts
.type
== BT_DERIVED
)
7194 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7195 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7196 tmp
= gfc_class_vptr_get (dest
);
7197 gfc_add_modify (&block
, tmp
,
7198 fold_convert (TREE_TYPE (tmp
), vtab
));
7199 tmp
= gfc_class_data_get (dest
);
7200 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7201 gfc_add_expr_to_block (&block
, tmp
);
7203 else if (init
&& (cm
->attr
.allocatable
7204 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7205 && expr
->ts
.type
!= BT_CLASS
)))
7207 /* Take care about non-array allocatable components here. The alloc_*
7208 routine below is motivated by the alloc_scalar_allocatable_for_
7209 assignment() routine, but with the realloc portions removed and
7211 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7216 /* The remainder of these instructions follow the if (cm->attr.pointer)
7217 if (!cm->attr.dimension) part above. */
7218 gfc_init_se (&se
, NULL
);
7219 gfc_conv_expr (&se
, expr
);
7220 gfc_add_block_to_block (&block
, &se
.pre
);
7222 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7223 && expr
->symtree
->n
.sym
->attr
.dummy
)
7224 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7226 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7228 tmp
= gfc_class_data_get (dest
);
7229 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7230 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7231 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7232 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7233 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7236 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7238 /* For deferred strings insert a memcpy. */
7239 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7242 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7243 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7245 : expr
->ts
.u
.cl
->backend_decl
);
7246 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7247 gfc_add_expr_to_block (&block
, tmp
);
7250 gfc_add_modify (&block
, tmp
,
7251 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7252 gfc_add_block_to_block (&block
, &se
.post
);
7254 else if (gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.f90_type
!= BT_VOID
)
7256 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7258 tree dealloc
= NULL_TREE
;
7259 gfc_init_se (&se
, NULL
);
7260 gfc_conv_expr (&se
, expr
);
7261 gfc_add_block_to_block (&block
, &se
.pre
);
7262 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7263 expression in a temporary variable and deallocate the allocatable
7264 components. Then we can the copy the expression to the result. */
7265 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7266 && expr
->expr_type
!= EXPR_VARIABLE
)
7268 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7269 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7272 gfc_add_modify (&block
, dest
,
7273 fold_convert (TREE_TYPE (dest
), se
.expr
));
7274 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7275 && expr
->expr_type
!= EXPR_NULL
)
7277 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7279 gfc_add_expr_to_block (&block
, tmp
);
7280 if (dealloc
!= NULL_TREE
)
7281 gfc_add_expr_to_block (&block
, dealloc
);
7283 gfc_add_block_to_block (&block
, &se
.post
);
7287 /* Nested constructors. */
7288 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7289 gfc_add_expr_to_block (&block
, tmp
);
7292 else if (gfc_deferred_strlen (cm
, &tmp
))
7296 gcc_assert (strlen
);
7297 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7299 TREE_OPERAND (dest
, 0),
7302 if (expr
->expr_type
== EXPR_NULL
)
7304 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7305 gfc_add_modify (&block
, dest
, tmp
);
7306 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7307 gfc_add_modify (&block
, strlen
, tmp
);
7312 gfc_init_se (&se
, NULL
);
7313 gfc_conv_expr (&se
, expr
);
7314 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7315 tmp
= build_call_expr_loc (input_location
,
7316 builtin_decl_explicit (BUILT_IN_MALLOC
),
7318 gfc_add_modify (&block
, dest
,
7319 fold_convert (TREE_TYPE (dest
), tmp
));
7320 gfc_add_modify (&block
, strlen
, se
.string_length
);
7321 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7322 gfc_add_expr_to_block (&block
, tmp
);
7325 else if (!cm
->attr
.artificial
)
7327 /* Scalar component (excluding deferred parameters). */
7328 gfc_init_se (&se
, NULL
);
7329 gfc_init_se (&lse
, NULL
);
7331 gfc_conv_expr (&se
, expr
);
7332 if (cm
->ts
.type
== BT_CHARACTER
)
7333 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7335 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7336 gfc_add_expr_to_block (&block
, tmp
);
7338 return gfc_finish_block (&block
);
7341 /* Assign a derived type constructor to a variable. */
7344 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7352 gfc_start_block (&block
);
7353 cm
= expr
->ts
.u
.derived
->components
;
7355 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7356 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7357 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7361 gcc_assert (cm
->backend_decl
== NULL
);
7362 gfc_init_se (&se
, NULL
);
7363 gfc_init_se (&lse
, NULL
);
7364 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7366 gfc_add_modify (&block
, lse
.expr
,
7367 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7369 return gfc_finish_block (&block
);
7372 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7373 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7375 /* Skip absent members in default initializers. */
7376 if (!c
->expr
&& !cm
->attr
.allocatable
)
7379 field
= cm
->backend_decl
;
7380 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7381 dest
, field
, NULL_TREE
);
7384 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7385 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7390 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7391 expr
->ts
.u
.derived
, init
);
7392 gfc_add_expr_to_block (&block
, tmp
);
7394 return gfc_finish_block (&block
);
7397 /* Build an expression for a constructor. If init is nonzero then
7398 this is part of a static variable initializer. */
7401 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7408 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7410 gcc_assert (se
->ss
== NULL
);
7411 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7412 type
= gfc_typenode_for_spec (&expr
->ts
);
7416 /* Create a temporary variable and fill it in. */
7417 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7418 /* The symtree in expr is NULL, if the code to generate is for
7419 initializing the static members only. */
7420 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7421 gfc_add_expr_to_block (&se
->pre
, tmp
);
7425 /* Though unions appear to have multiple map components, they must only
7426 have a single initializer since each map overlaps. TODO: squash map
7428 if (expr
->ts
.type
== BT_UNION
)
7430 c
= gfc_constructor_first (expr
->value
.constructor
);
7431 cm
= c
->n
.component
;
7432 val
= gfc_conv_initializer (c
->expr
, &expr
->ts
,
7433 TREE_TYPE (cm
->backend_decl
),
7434 cm
->attr
.dimension
, cm
->attr
.pointer
,
7435 cm
->attr
.proc_pointer
);
7436 val
= unshare_expr_without_location (val
);
7438 /* Append it to the constructor list. */
7439 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7443 cm
= expr
->ts
.u
.derived
->components
;
7445 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7446 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7448 /* Skip absent members in default initializers and allocatable
7449 components. Although the latter have a default initializer
7450 of EXPR_NULL,... by default, the static nullify is not needed
7451 since this is done every time we come into scope. */
7452 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7455 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7456 && strcmp (cm
->name
, "_extends") == 0
7457 && cm
->initializer
->symtree
)
7461 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7462 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7463 vtab
= unshare_expr_without_location (vtab
);
7464 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7466 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7468 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7469 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7470 fold_convert (TREE_TYPE (cm
->backend_decl
),
7473 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7474 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7475 fold_convert (TREE_TYPE (cm
->backend_decl
),
7476 integer_zero_node
));
7479 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7480 TREE_TYPE (cm
->backend_decl
),
7481 cm
->attr
.dimension
, cm
->attr
.pointer
,
7482 cm
->attr
.proc_pointer
);
7483 val
= unshare_expr_without_location (val
);
7485 /* Append it to the constructor list. */
7486 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7490 se
->expr
= build_constructor (type
, v
);
7492 TREE_CONSTANT (se
->expr
) = 1;
7496 /* Translate a substring expression. */
7499 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7505 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7507 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7508 expr
->value
.character
.length
,
7509 expr
->value
.character
.string
);
7511 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7512 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7515 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7519 /* Entry point for expression translation. Evaluates a scalar quantity.
7520 EXPR is the expression to be translated, and SE is the state structure if
7521 called from within the scalarized. */
7524 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7529 if (ss
&& ss
->info
->expr
== expr
7530 && (ss
->info
->type
== GFC_SS_SCALAR
7531 || ss
->info
->type
== GFC_SS_REFERENCE
))
7533 gfc_ss_info
*ss_info
;
7536 /* Substitute a scalar expression evaluated outside the scalarization
7538 se
->expr
= ss_info
->data
.scalar
.value
;
7539 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7540 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7542 se
->string_length
= ss_info
->string_length
;
7543 gfc_advance_se_ss_chain (se
);
7547 /* We need to convert the expressions for the iso_c_binding derived types.
7548 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7549 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7550 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7551 updated to be an integer with a kind equal to the size of a (void *). */
7552 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7553 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7555 if (expr
->expr_type
== EXPR_VARIABLE
7556 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7557 || expr
->symtree
->n
.sym
->intmod_sym_id
7558 == ISOCBINDING_NULL_FUNPTR
))
7560 /* Set expr_type to EXPR_NULL, which will result in
7561 null_pointer_node being used below. */
7562 expr
->expr_type
= EXPR_NULL
;
7566 /* Update the type/kind of the expression to be what the new
7567 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7568 expr
->ts
.type
= BT_INTEGER
;
7569 expr
->ts
.f90_type
= BT_VOID
;
7570 expr
->ts
.kind
= gfc_index_integer_kind
;
7574 gfc_fix_class_refs (expr
);
7576 switch (expr
->expr_type
)
7579 gfc_conv_expr_op (se
, expr
);
7583 gfc_conv_function_expr (se
, expr
);
7587 gfc_conv_constant (se
, expr
);
7591 gfc_conv_variable (se
, expr
);
7595 se
->expr
= null_pointer_node
;
7598 case EXPR_SUBSTRING
:
7599 gfc_conv_substring_expr (se
, expr
);
7602 case EXPR_STRUCTURE
:
7603 gfc_conv_structure (se
, expr
, 0);
7607 gfc_conv_array_constructor_expr (se
, expr
);
7616 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7617 of an assignment. */
7619 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7621 gfc_conv_expr (se
, expr
);
7622 /* All numeric lvalues should have empty post chains. If not we need to
7623 figure out a way of rewriting an lvalue so that it has no post chain. */
7624 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7627 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7628 numeric expressions. Used for scalar values where inserting cleanup code
7631 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7635 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7636 gfc_conv_expr (se
, expr
);
7639 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7640 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7642 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7646 /* Helper to translate an expression and convert it to a particular type. */
7648 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7650 gfc_conv_expr_val (se
, expr
);
7651 se
->expr
= convert (type
, se
->expr
);
7655 /* Converts an expression so that it can be passed by reference. Scalar
7659 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7665 if (ss
&& ss
->info
->expr
== expr
7666 && ss
->info
->type
== GFC_SS_REFERENCE
)
7668 /* Returns a reference to the scalar evaluated outside the loop
7670 gfc_conv_expr (se
, expr
);
7672 if (expr
->ts
.type
== BT_CHARACTER
7673 && expr
->expr_type
!= EXPR_FUNCTION
)
7674 gfc_conv_string_parameter (se
);
7676 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7681 if (expr
->ts
.type
== BT_CHARACTER
)
7683 gfc_conv_expr (se
, expr
);
7684 gfc_conv_string_parameter (se
);
7688 if (expr
->expr_type
== EXPR_VARIABLE
)
7690 se
->want_pointer
= 1;
7691 gfc_conv_expr (se
, expr
);
7694 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7695 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7696 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7702 if (expr
->expr_type
== EXPR_FUNCTION
7703 && ((expr
->value
.function
.esym
7704 && expr
->value
.function
.esym
->result
->attr
.pointer
7705 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7706 || (!expr
->value
.function
.esym
&& !expr
->ref
7707 && expr
->symtree
->n
.sym
->attr
.pointer
7708 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7710 se
->want_pointer
= 1;
7711 gfc_conv_expr (se
, expr
);
7712 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7713 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7718 gfc_conv_expr (se
, expr
);
7720 /* Create a temporary var to hold the value. */
7721 if (TREE_CONSTANT (se
->expr
))
7723 tree tmp
= se
->expr
;
7724 STRIP_TYPE_NOPS (tmp
);
7725 var
= build_decl (input_location
,
7726 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7727 DECL_INITIAL (var
) = tmp
;
7728 TREE_STATIC (var
) = 1;
7733 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7734 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7736 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7738 /* Take the address of that value. */
7739 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7744 gfc_trans_pointer_assign (gfc_code
* code
)
7746 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7750 /* Generate code for a pointer assignment. */
7753 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7755 gfc_expr
*expr1_vptr
= NULL
;
7765 gfc_start_block (&block
);
7767 gfc_init_se (&lse
, NULL
);
7769 /* Check whether the expression is a scalar or not; we cannot use
7770 expr1->rank as it can be nonzero for proc pointers. */
7771 ss
= gfc_walk_expr (expr1
);
7772 scalar
= ss
== gfc_ss_terminator
;
7774 gfc_free_ss_chain (ss
);
7776 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7777 && expr2
->expr_type
!= EXPR_FUNCTION
)
7779 gfc_add_data_component (expr2
);
7780 /* The following is required as gfc_add_data_component doesn't
7781 update ts.type if there is a tailing REF_ARRAY. */
7782 expr2
->ts
.type
= BT_DERIVED
;
7787 /* Scalar pointers. */
7788 lse
.want_pointer
= 1;
7789 gfc_conv_expr (&lse
, expr1
);
7790 gfc_init_se (&rse
, NULL
);
7791 rse
.want_pointer
= 1;
7792 gfc_conv_expr (&rse
, expr2
);
7794 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7795 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7796 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7799 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7800 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7801 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7804 gfc_add_block_to_block (&block
, &lse
.pre
);
7805 gfc_add_block_to_block (&block
, &rse
.pre
);
7807 /* For string assignments to unlimited polymorphic pointers add an
7808 assignment of the string_length to the _len component of the
7810 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7811 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7812 && (expr2
->ts
.type
== BT_CHARACTER
||
7813 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7814 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7818 len_comp
= gfc_get_len_component (expr1
);
7819 gfc_init_se (&se
, NULL
);
7820 gfc_conv_expr (&se
, len_comp
);
7822 /* ptr % _len = len (str) */
7823 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7824 lse
.string_length
= se
.expr
;
7825 gfc_free_expr (len_comp
);
7828 /* Check character lengths if character expression. The test is only
7829 really added if -fbounds-check is enabled. Exclude deferred
7830 character length lefthand sides. */
7831 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7832 && !expr1
->ts
.deferred
7833 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7834 && !gfc_is_proc_ptr_comp (expr1
))
7836 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7837 gcc_assert (lse
.string_length
&& rse
.string_length
);
7838 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7839 lse
.string_length
, rse
.string_length
,
7843 /* The assignment to an deferred character length sets the string
7844 length to that of the rhs. */
7845 if (expr1
->ts
.deferred
)
7847 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7848 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7849 else if (lse
.string_length
!= NULL
)
7850 gfc_add_modify (&block
, lse
.string_length
,
7851 build_int_cst (gfc_charlen_type_node
, 0));
7854 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7855 rse
.expr
= gfc_class_data_get (rse
.expr
);
7857 gfc_add_modify (&block
, lse
.expr
,
7858 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7860 gfc_add_block_to_block (&block
, &rse
.post
);
7861 gfc_add_block_to_block (&block
, &lse
.post
);
7868 tree strlen_rhs
= NULL_TREE
;
7870 /* Array pointer. Find the last reference on the LHS and if it is an
7871 array section ref, we're dealing with bounds remapping. In this case,
7872 set it to AR_FULL so that gfc_conv_expr_descriptor does
7873 not see it and process the bounds remapping afterwards explicitly. */
7874 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7875 if (!remap
->next
&& remap
->type
== REF_ARRAY
7876 && remap
->u
.ar
.type
== AR_SECTION
)
7878 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7880 gfc_init_se (&lse
, NULL
);
7882 lse
.descriptor_only
= 1;
7883 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7884 && expr1
->ts
.type
== BT_CLASS
)
7885 expr1_vptr
= gfc_copy_expr (expr1
);
7886 gfc_conv_expr_descriptor (&lse
, expr1
);
7887 strlen_lhs
= lse
.string_length
;
7890 if (expr2
->expr_type
== EXPR_NULL
)
7892 /* Just set the data pointer to null. */
7893 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7895 else if (rank_remap
)
7897 /* If we are rank-remapping, just get the RHS's descriptor and
7898 process this later on. */
7899 gfc_init_se (&rse
, NULL
);
7900 rse
.direct_byref
= 1;
7901 rse
.byref_noassign
= 1;
7903 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7905 gfc_conv_function_expr (&rse
, expr2
);
7907 if (expr1
->ts
.type
!= BT_CLASS
)
7908 rse
.expr
= gfc_class_data_get (rse
.expr
);
7911 gfc_add_block_to_block (&block
, &rse
.pre
);
7912 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7913 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7915 gfc_add_vptr_component (expr1_vptr
);
7916 gfc_init_se (&rse
, NULL
);
7917 rse
.want_pointer
= 1;
7918 gfc_conv_expr (&rse
, expr1_vptr
);
7919 gfc_add_modify (&lse
.pre
, rse
.expr
,
7920 fold_convert (TREE_TYPE (rse
.expr
),
7921 gfc_class_vptr_get (tmp
)));
7922 rse
.expr
= gfc_class_data_get (tmp
);
7925 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7927 tree bound
[GFC_MAX_DIMENSIONS
];
7930 for (i
= 0; i
< expr2
->rank
; i
++)
7931 bound
[i
] = NULL_TREE
;
7932 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7933 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7935 GFC_ARRAY_POINTER_CONT
, false);
7936 tmp
= gfc_create_var (tmp
, "ptrtemp");
7937 rse
.descriptor_only
= 0;
7939 rse
.direct_byref
= 1;
7940 gfc_conv_expr_descriptor (&rse
, expr2
);
7941 strlen_rhs
= rse
.string_length
;
7946 gfc_conv_expr_descriptor (&rse
, expr2
);
7947 strlen_rhs
= rse
.string_length
;
7950 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7952 /* Assign directly to the LHS's descriptor. */
7953 lse
.descriptor_only
= 0;
7954 lse
.direct_byref
= 1;
7955 gfc_conv_expr_descriptor (&lse
, expr2
);
7956 strlen_rhs
= lse
.string_length
;
7958 /* If this is a subreference array pointer assignment, use the rhs
7959 descriptor element size for the lhs span. */
7960 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7962 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7963 gfc_init_se (&rse
, NULL
);
7964 rse
.descriptor_only
= 1;
7965 gfc_conv_expr (&rse
, expr2
);
7966 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7967 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7968 if (!INTEGER_CST_P (tmp
))
7969 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7970 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7973 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7975 gfc_init_se (&rse
, NULL
);
7976 rse
.want_pointer
= 1;
7977 gfc_conv_function_expr (&rse
, expr2
);
7978 if (expr1
->ts
.type
!= BT_CLASS
)
7980 rse
.expr
= gfc_class_data_get (rse
.expr
);
7981 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7985 gfc_add_block_to_block (&block
, &rse
.pre
);
7986 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7987 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7989 gfc_add_vptr_component (expr1_vptr
);
7990 gfc_init_se (&rse
, NULL
);
7991 rse
.want_pointer
= 1;
7992 gfc_conv_expr (&rse
, expr1_vptr
);
7993 gfc_add_modify (&lse
.pre
, rse
.expr
,
7994 fold_convert (TREE_TYPE (rse
.expr
),
7995 gfc_class_vptr_get (tmp
)));
7996 rse
.expr
= gfc_class_data_get (tmp
);
7997 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
8002 /* Assign to a temporary descriptor and then copy that
8003 temporary to the pointer. */
8004 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
8005 lse
.descriptor_only
= 0;
8007 lse
.direct_byref
= 1;
8008 gfc_conv_expr_descriptor (&lse
, expr2
);
8009 strlen_rhs
= lse
.string_length
;
8010 gfc_add_modify (&lse
.pre
, desc
, tmp
);
8014 gfc_free_expr (expr1_vptr
);
8016 gfc_add_block_to_block (&block
, &lse
.pre
);
8018 gfc_add_block_to_block (&block
, &rse
.pre
);
8020 /* If we do bounds remapping, update LHS descriptor accordingly. */
8024 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
8028 /* Do rank remapping. We already have the RHS's descriptor
8029 converted in rse and now have to build the correct LHS
8030 descriptor for it. */
8034 tree lbound
, ubound
;
8037 dtype
= gfc_conv_descriptor_dtype (desc
);
8038 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
8039 gfc_add_modify (&block
, dtype
, tmp
);
8041 /* Copy data pointer. */
8042 data
= gfc_conv_descriptor_data_get (rse
.expr
);
8043 gfc_conv_descriptor_data_set (&block
, desc
, data
);
8045 /* Copy offset but adjust it such that it would correspond
8046 to a lbound of zero. */
8047 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
8048 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
8050 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8052 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
8054 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8055 gfc_array_index_type
, stride
, lbound
);
8056 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
8057 gfc_array_index_type
, offs
, tmp
);
8059 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8061 /* Set the bounds as declared for the LHS and calculate strides as
8062 well as another offset update accordingly. */
8063 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8065 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8070 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8072 /* Convert declared bounds. */
8073 gfc_init_se (&lower_se
, NULL
);
8074 gfc_init_se (&upper_se
, NULL
);
8075 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8076 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8078 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8079 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8081 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8082 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8084 lbound
= gfc_evaluate_now (lbound
, &block
);
8085 ubound
= gfc_evaluate_now (ubound
, &block
);
8087 gfc_add_block_to_block (&block
, &lower_se
.post
);
8088 gfc_add_block_to_block (&block
, &upper_se
.post
);
8090 /* Set bounds in descriptor. */
8091 gfc_conv_descriptor_lbound_set (&block
, desc
,
8092 gfc_rank_cst
[dim
], lbound
);
8093 gfc_conv_descriptor_ubound_set (&block
, desc
,
8094 gfc_rank_cst
[dim
], ubound
);
8097 stride
= gfc_evaluate_now (stride
, &block
);
8098 gfc_conv_descriptor_stride_set (&block
, desc
,
8099 gfc_rank_cst
[dim
], stride
);
8101 /* Update offset. */
8102 offs
= gfc_conv_descriptor_offset_get (desc
);
8103 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8104 gfc_array_index_type
, lbound
, stride
);
8105 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8106 gfc_array_index_type
, offs
, tmp
);
8107 offs
= gfc_evaluate_now (offs
, &block
);
8108 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8110 /* Update stride. */
8111 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8112 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8113 gfc_array_index_type
, stride
, tmp
);
8118 /* Bounds remapping. Just shift the lower bounds. */
8120 gcc_assert (expr1
->rank
== expr2
->rank
);
8122 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8126 gcc_assert (remap
->u
.ar
.start
[dim
]);
8127 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8128 gfc_init_se (&lbound_se
, NULL
);
8129 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8131 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8132 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8133 dim
, lbound_se
.expr
);
8134 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8139 /* Check string lengths if applicable. The check is only really added
8140 to the output code if -fbounds-check is enabled. */
8141 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8143 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8144 gcc_assert (strlen_lhs
&& strlen_rhs
);
8145 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8146 strlen_lhs
, strlen_rhs
, &block
);
8149 /* If rank remapping was done, check with -fcheck=bounds that
8150 the target is at least as large as the pointer. */
8151 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8157 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8158 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8160 lsize
= gfc_evaluate_now (lsize
, &block
);
8161 rsize
= gfc_evaluate_now (rsize
, &block
);
8162 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8165 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8166 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8170 gfc_add_block_to_block (&block
, &lse
.post
);
8172 gfc_add_block_to_block (&block
, &rse
.post
);
8175 return gfc_finish_block (&block
);
8179 /* Makes sure se is suitable for passing as a function string parameter. */
8180 /* TODO: Need to check all callers of this function. It may be abused. */
8183 gfc_conv_string_parameter (gfc_se
* se
)
8187 if (TREE_CODE (se
->expr
) == STRING_CST
)
8189 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8190 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8194 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8196 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8198 type
= TREE_TYPE (se
->expr
);
8199 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8203 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8205 type
= build_pointer_type (type
);
8206 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8210 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8214 /* Generate code for assignment of scalar variables. Includes character
8215 strings and derived types with allocatable components.
8216 If you know that the LHS has no allocations, set dealloc to false.
8218 DEEP_COPY has no effect if the typespec TS is not a derived type with
8219 allocatable components. Otherwise, if it is set, an explicit copy of each
8220 allocatable component is made. This is necessary as a simple copy of the
8221 whole object would copy array descriptors as is, so that the lhs's
8222 allocatable components would point to the rhs's after the assignment.
8223 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8224 necessary if the rhs is a non-pointer function, as the allocatable components
8225 are not accessible by other means than the function's result after the
8226 function has returned. It is even more subtle when temporaries are involved,
8227 as the two following examples show:
8228 1. When we evaluate an array constructor, a temporary is created. Thus
8229 there is theoretically no alias possible. However, no deep copy is
8230 made for this temporary, so that if the constructor is made of one or
8231 more variable with allocatable components, those components still point
8232 to the variable's: DEEP_COPY should be set for the assignment from the
8233 temporary to the lhs in that case.
8234 2. When assigning a scalar to an array, we evaluate the scalar value out
8235 of the loop, store it into a temporary variable, and assign from that.
8236 In that case, deep copying when assigning to the temporary would be a
8237 waste of resources; however deep copies should happen when assigning from
8238 the temporary to each array element: again DEEP_COPY should be set for
8239 the assignment from the temporary to the lhs. */
8242 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8243 bool deep_copy
, bool dealloc
)
8249 gfc_init_block (&block
);
8251 if (ts
.type
== BT_CHARACTER
)
8256 if (lse
->string_length
!= NULL_TREE
)
8258 gfc_conv_string_parameter (lse
);
8259 gfc_add_block_to_block (&block
, &lse
->pre
);
8260 llen
= lse
->string_length
;
8263 if (rse
->string_length
!= NULL_TREE
)
8265 gcc_assert (rse
->string_length
!= NULL_TREE
);
8266 gfc_conv_string_parameter (rse
);
8267 gfc_add_block_to_block (&block
, &rse
->pre
);
8268 rlen
= rse
->string_length
;
8271 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8272 rse
->expr
, ts
.kind
);
8274 else if (gfc_bt_struct (ts
.type
) && ts
.u
.derived
->attr
.alloc_comp
)
8276 tree tmp_var
= NULL_TREE
;
8279 /* Are the rhs and the lhs the same? */
8282 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8283 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8284 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8285 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8288 /* Deallocate the lhs allocated components as long as it is not
8289 the same as the rhs. This must be done following the assignment
8290 to prevent deallocating data that could be used in the rhs
8294 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8295 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8297 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8299 gfc_add_expr_to_block (&lse
->post
, tmp
);
8302 gfc_add_block_to_block (&block
, &rse
->pre
);
8303 gfc_add_block_to_block (&block
, &lse
->pre
);
8305 gfc_add_modify (&block
, lse
->expr
,
8306 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8308 /* Restore pointer address of coarray components. */
8309 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8311 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8312 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8314 gfc_add_expr_to_block (&block
, tmp
);
8317 /* Do a deep copy if the rhs is a variable, if it is not the
8321 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8322 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8324 gfc_add_expr_to_block (&block
, tmp
);
8327 else if (gfc_bt_struct (ts
.type
) || ts
.type
== BT_CLASS
)
8329 gfc_add_block_to_block (&block
, &lse
->pre
);
8330 gfc_add_block_to_block (&block
, &rse
->pre
);
8331 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8332 TREE_TYPE (lse
->expr
), rse
->expr
);
8333 gfc_add_modify (&block
, lse
->expr
, tmp
);
8337 gfc_add_block_to_block (&block
, &lse
->pre
);
8338 gfc_add_block_to_block (&block
, &rse
->pre
);
8340 gfc_add_modify (&block
, lse
->expr
,
8341 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8344 gfc_add_block_to_block (&block
, &lse
->post
);
8345 gfc_add_block_to_block (&block
, &rse
->post
);
8347 return gfc_finish_block (&block
);
8351 /* There are quite a lot of restrictions on the optimisation in using an
8352 array function assign without a temporary. */
8355 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8358 bool seen_array_ref
;
8360 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8362 /* Play it safe with class functions assigned to a derived type. */
8363 if (gfc_is_alloc_class_array_function (expr2
)
8364 && expr1
->ts
.type
== BT_DERIVED
)
8367 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8368 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8371 /* Elemental functions are scalarized so that they don't need a
8372 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8373 they would need special treatment in gfc_trans_arrayfunc_assign. */
8374 if (expr2
->value
.function
.esym
!= NULL
8375 && expr2
->value
.function
.esym
->attr
.elemental
)
8378 /* Need a temporary if rhs is not FULL or a contiguous section. */
8379 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8382 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8383 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8386 /* Functions returning pointers or allocatables need temporaries. */
8387 c
= expr2
->value
.function
.esym
8388 ? (expr2
->value
.function
.esym
->attr
.pointer
8389 || expr2
->value
.function
.esym
->attr
.allocatable
)
8390 : (expr2
->symtree
->n
.sym
->attr
.pointer
8391 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8395 /* Character array functions need temporaries unless the
8396 character lengths are the same. */
8397 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8399 if (expr1
->ts
.u
.cl
->length
== NULL
8400 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8403 if (expr2
->ts
.u
.cl
->length
== NULL
8404 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8407 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8408 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8412 /* Check that no LHS component references appear during an array
8413 reference. This is needed because we do not have the means to
8414 span any arbitrary stride with an array descriptor. This check
8415 is not needed for the rhs because the function result has to be
8417 seen_array_ref
= false;
8418 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8420 if (ref
->type
== REF_ARRAY
)
8421 seen_array_ref
= true;
8422 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8426 /* Check for a dependency. */
8427 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8428 expr2
->value
.function
.esym
,
8429 expr2
->value
.function
.actual
,
8433 /* If we have reached here with an intrinsic function, we do not
8434 need a temporary except in the particular case that reallocation
8435 on assignment is active and the lhs is allocatable and a target. */
8436 if (expr2
->value
.function
.isym
)
8437 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8439 /* If the LHS is a dummy, we need a temporary if it is not
8441 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8444 /* If the lhs has been host_associated, is in common, a pointer or is
8445 a target and the function is not using a RESULT variable, aliasing
8446 can occur and a temporary is needed. */
8447 if ((sym
->attr
.host_assoc
8448 || sym
->attr
.in_common
8449 || sym
->attr
.pointer
8450 || sym
->attr
.cray_pointee
8451 || sym
->attr
.target
)
8452 && expr2
->symtree
!= NULL
8453 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8456 /* A PURE function can unconditionally be called without a temporary. */
8457 if (expr2
->value
.function
.esym
!= NULL
8458 && expr2
->value
.function
.esym
->attr
.pure
)
8461 /* Implicit_pure functions are those which could legally be declared
8463 if (expr2
->value
.function
.esym
!= NULL
8464 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8467 if (!sym
->attr
.use_assoc
8468 && !sym
->attr
.in_common
8469 && !sym
->attr
.pointer
8470 && !sym
->attr
.target
8471 && !sym
->attr
.cray_pointee
8472 && expr2
->value
.function
.esym
)
8474 /* A temporary is not needed if the function is not contained and
8475 the variable is local or host associated and not a pointer or
8477 if (!expr2
->value
.function
.esym
->attr
.contained
)
8480 /* A temporary is not needed if the lhs has never been host
8481 associated and the procedure is contained. */
8482 else if (!sym
->attr
.host_assoc
)
8485 /* A temporary is not needed if the variable is local and not
8486 a pointer, a target or a result. */
8488 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8492 /* Default to temporary use. */
8497 /* Provide the loop info so that the lhs descriptor can be built for
8498 reallocatable assignments from extrinsic function calls. */
8501 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8504 /* Signal that the function call should not be made by
8505 gfc_conv_loop_setup. */
8506 se
->ss
->is_alloc_lhs
= 1;
8507 gfc_init_loopinfo (loop
);
8508 gfc_add_ss_to_loop (loop
, *ss
);
8509 gfc_add_ss_to_loop (loop
, se
->ss
);
8510 gfc_conv_ss_startstride (loop
);
8511 gfc_conv_loop_setup (loop
, where
);
8512 gfc_copy_loopinfo_to_se (se
, loop
);
8513 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8514 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8515 se
->ss
->is_alloc_lhs
= 0;
8519 /* For assignment to a reallocatable lhs from intrinsic functions,
8520 replace the se.expr (ie. the result) with a temporary descriptor.
8521 Null the data field so that the library allocates space for the
8522 result. Free the data of the original descriptor after the function,
8523 in case it appears in an argument expression and transfer the
8524 result to the original descriptor. */
8527 fcncall_realloc_result (gfc_se
*se
, int rank
)
8536 /* Use the allocation done by the library. Substitute the lhs
8537 descriptor with a copy, whose data field is nulled.*/
8538 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8539 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8540 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8542 /* Unallocated, the descriptor does not have a dtype. */
8543 tmp
= gfc_conv_descriptor_dtype (desc
);
8544 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8546 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8547 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8548 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8550 /* Free the lhs after the function call and copy the result data to
8551 the lhs descriptor. */
8552 tmp
= gfc_conv_descriptor_data_get (desc
);
8553 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8554 boolean_type_node
, tmp
,
8555 build_int_cst (TREE_TYPE (tmp
), 0));
8556 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8557 tmp
= gfc_call_free (tmp
);
8558 gfc_add_expr_to_block (&se
->post
, tmp
);
8560 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8561 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8563 /* Check that the shapes are the same between lhs and expression. */
8564 for (n
= 0 ; n
< rank
; n
++)
8567 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8568 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8569 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8570 gfc_array_index_type
, tmp
, tmp1
);
8571 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8572 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8573 gfc_array_index_type
, tmp
, tmp1
);
8574 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8575 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8576 gfc_array_index_type
, tmp
, tmp1
);
8577 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8578 boolean_type_node
, tmp
,
8579 gfc_index_zero_node
);
8580 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8581 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8582 boolean_type_node
, tmp
,
8586 /* 'zero_cond' being true is equal to lhs not being allocated or the
8587 shapes being different. */
8588 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8590 /* Now reset the bounds returned from the function call to bounds based
8591 on the lhs lbounds, except where the lhs is not allocated or the shapes
8592 of 'variable and 'expr' are different. Set the offset accordingly. */
8593 offset
= gfc_index_zero_node
;
8594 for (n
= 0 ; n
< rank
; n
++)
8598 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8599 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8600 gfc_array_index_type
, zero_cond
,
8601 gfc_index_one_node
, lbound
);
8602 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8604 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8605 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8606 gfc_array_index_type
, tmp
, lbound
);
8607 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8608 gfc_rank_cst
[n
], lbound
);
8609 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8610 gfc_rank_cst
[n
], tmp
);
8612 /* Set stride and accumulate the offset. */
8613 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8614 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8615 gfc_rank_cst
[n
], tmp
);
8616 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8617 gfc_array_index_type
, lbound
, tmp
);
8618 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8619 gfc_array_index_type
, offset
, tmp
);
8620 offset
= gfc_evaluate_now (offset
, &se
->post
);
8623 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8628 /* Try to translate array(:) = func (...), where func is a transformational
8629 array function, without using a temporary. Returns NULL if this isn't the
8633 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8637 gfc_component
*comp
= NULL
;
8640 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8643 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8645 comp
= gfc_get_proc_ptr_comp (expr2
);
8646 gcc_assert (expr2
->value
.function
.isym
8647 || (comp
&& comp
->attr
.dimension
)
8648 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8649 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8651 gfc_init_se (&se
, NULL
);
8652 gfc_start_block (&se
.pre
);
8653 se
.want_pointer
= 1;
8655 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8657 if (expr1
->ts
.type
== BT_DERIVED
8658 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8661 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8663 gfc_add_expr_to_block (&se
.pre
, tmp
);
8666 se
.direct_byref
= 1;
8667 se
.ss
= gfc_walk_expr (expr2
);
8668 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8670 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8671 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8672 Clearly, this cannot be done for an allocatable function result, since
8673 the shape of the result is unknown and, in any case, the function must
8674 correctly take care of the reallocation internally. For intrinsic
8675 calls, the array data is freed and the library takes care of allocation.
8676 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8678 if (flag_realloc_lhs
8679 && gfc_is_reallocatable_lhs (expr1
)
8680 && !gfc_expr_attr (expr1
).codimension
8681 && !gfc_is_coindexed (expr1
)
8682 && !(expr2
->value
.function
.esym
8683 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8685 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8687 if (!expr2
->value
.function
.isym
)
8689 ss
= gfc_walk_expr (expr1
);
8690 gcc_assert (ss
!= gfc_ss_terminator
);
8692 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8693 ss
->is_alloc_lhs
= 1;
8696 fcncall_realloc_result (&se
, expr1
->rank
);
8699 gfc_conv_function_expr (&se
, expr2
);
8700 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8703 gfc_cleanup_loop (&loop
);
8705 gfc_free_ss_chain (se
.ss
);
8707 return gfc_finish_block (&se
.pre
);
8711 /* Try to efficiently translate array(:) = 0. Return NULL if this
8715 gfc_trans_zero_assign (gfc_expr
* expr
)
8717 tree dest
, len
, type
;
8721 sym
= expr
->symtree
->n
.sym
;
8722 dest
= gfc_get_symbol_decl (sym
);
8724 type
= TREE_TYPE (dest
);
8725 if (POINTER_TYPE_P (type
))
8726 type
= TREE_TYPE (type
);
8727 if (!GFC_ARRAY_TYPE_P (type
))
8730 /* Determine the length of the array. */
8731 len
= GFC_TYPE_ARRAY_SIZE (type
);
8732 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8735 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8736 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8737 fold_convert (gfc_array_index_type
, tmp
));
8739 /* If we are zeroing a local array avoid taking its address by emitting
8741 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8742 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8743 dest
, build_constructor (TREE_TYPE (dest
),
8746 /* Convert arguments to the correct types. */
8747 dest
= fold_convert (pvoid_type_node
, dest
);
8748 len
= fold_convert (size_type_node
, len
);
8750 /* Construct call to __builtin_memset. */
8751 tmp
= build_call_expr_loc (input_location
,
8752 builtin_decl_explicit (BUILT_IN_MEMSET
),
8753 3, dest
, integer_zero_node
, len
);
8754 return fold_convert (void_type_node
, tmp
);
8758 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8759 that constructs the call to __builtin_memcpy. */
8762 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8766 /* Convert arguments to the correct types. */
8767 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8768 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8770 dst
= fold_convert (pvoid_type_node
, dst
);
8772 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8773 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8775 src
= fold_convert (pvoid_type_node
, src
);
8777 len
= fold_convert (size_type_node
, len
);
8779 /* Construct call to __builtin_memcpy. */
8780 tmp
= build_call_expr_loc (input_location
,
8781 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8783 return fold_convert (void_type_node
, tmp
);
8787 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8788 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8789 source/rhs, both are gfc_full_array_ref_p which have been checked for
8793 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8795 tree dst
, dlen
, dtype
;
8796 tree src
, slen
, stype
;
8799 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8800 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8802 dtype
= TREE_TYPE (dst
);
8803 if (POINTER_TYPE_P (dtype
))
8804 dtype
= TREE_TYPE (dtype
);
8805 stype
= TREE_TYPE (src
);
8806 if (POINTER_TYPE_P (stype
))
8807 stype
= TREE_TYPE (stype
);
8809 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8812 /* Determine the lengths of the arrays. */
8813 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8814 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8816 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8817 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8818 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8820 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8821 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8823 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8824 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8825 slen
, fold_convert (gfc_array_index_type
, tmp
));
8827 /* Sanity check that they are the same. This should always be
8828 the case, as we should already have checked for conformance. */
8829 if (!tree_int_cst_equal (slen
, dlen
))
8832 return gfc_build_memcpy_call (dst
, src
, dlen
);
8836 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8837 this can't be done. EXPR1 is the destination/lhs for which
8838 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8841 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8843 unsigned HOST_WIDE_INT nelem
;
8849 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8853 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8854 dtype
= TREE_TYPE (dst
);
8855 if (POINTER_TYPE_P (dtype
))
8856 dtype
= TREE_TYPE (dtype
);
8857 if (!GFC_ARRAY_TYPE_P (dtype
))
8860 /* Determine the lengths of the array. */
8861 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8862 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8865 /* Confirm that the constructor is the same size. */
8866 if (compare_tree_int (len
, nelem
) != 0)
8869 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8870 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8871 fold_convert (gfc_array_index_type
, tmp
));
8873 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8874 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8876 stype
= TREE_TYPE (src
);
8877 if (POINTER_TYPE_P (stype
))
8878 stype
= TREE_TYPE (stype
);
8880 return gfc_build_memcpy_call (dst
, src
, len
);
8884 /* Tells whether the expression is to be treated as a variable reference. */
8887 gfc_expr_is_variable (gfc_expr
*expr
)
8890 gfc_component
*comp
;
8891 gfc_symbol
*func_ifc
;
8893 if (expr
->expr_type
== EXPR_VARIABLE
)
8896 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8899 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8900 return gfc_expr_is_variable (arg
);
8903 /* A data-pointer-returning function should be considered as a variable
8905 if (expr
->expr_type
== EXPR_FUNCTION
8906 && expr
->ref
== NULL
)
8908 if (expr
->value
.function
.isym
!= NULL
)
8911 if (expr
->value
.function
.esym
!= NULL
)
8913 func_ifc
= expr
->value
.function
.esym
;
8918 gcc_assert (expr
->symtree
);
8919 func_ifc
= expr
->symtree
->n
.sym
;
8926 comp
= gfc_get_proc_ptr_comp (expr
);
8927 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8930 func_ifc
= comp
->ts
.interface
;
8934 if (expr
->expr_type
== EXPR_COMPCALL
)
8936 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8937 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8944 gcc_assert (func_ifc
->attr
.function
8945 && func_ifc
->result
!= NULL
);
8946 return func_ifc
->result
->attr
.pointer
;
8950 /* Is the lhs OK for automatic reallocation? */
8953 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8957 /* An allocatable variable with no reference. */
8958 if (expr
->symtree
->n
.sym
->attr
.allocatable
8962 /* All that can be left are allocatable components. However, we do
8963 not check for allocatable components here because the expression
8964 could be an allocatable component of a pointer component. */
8965 if (expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8966 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8969 /* Find an allocatable component ref last. */
8970 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8971 if (ref
->type
== REF_COMPONENT
8973 && ref
->u
.c
.component
->attr
.allocatable
)
8980 /* Allocate or reallocate scalar lhs, as necessary. */
8983 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8998 if (!expr1
|| expr1
->rank
)
9001 if (!expr2
|| expr2
->rank
)
9004 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
9005 if (ref
->type
== REF_SUBSTRING
)
9008 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
9010 /* Since this is a scalar lhs, we can afford to do this. That is,
9011 there is no risk of side effects being repeated. */
9012 gfc_init_se (&lse
, NULL
);
9013 lse
.want_pointer
= 1;
9014 gfc_conv_expr (&lse
, expr1
);
9016 jump_label1
= gfc_build_label_decl (NULL_TREE
);
9017 jump_label2
= gfc_build_label_decl (NULL_TREE
);
9019 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9020 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
9021 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
9023 tmp
= build3_v (COND_EXPR
, cond
,
9024 build1_v (GOTO_EXPR
, jump_label1
),
9025 build_empty_stmt (input_location
));
9026 gfc_add_expr_to_block (block
, tmp
);
9028 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9030 /* Use the rhs string length and the lhs element size. */
9031 size
= string_length
;
9032 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
9033 tmp
= TYPE_SIZE_UNIT (tmp
);
9034 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
9035 TREE_TYPE (tmp
), tmp
,
9036 fold_convert (TREE_TYPE (tmp
), size
));
9040 /* Otherwise use the length in bytes of the rhs. */
9041 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
9042 size_in_bytes
= size
;
9045 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
9046 size_in_bytes
, size_one_node
);
9048 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
9050 tmp
= build_call_expr_loc (input_location
,
9051 builtin_decl_explicit (BUILT_IN_CALLOC
),
9052 2, build_one_cst (size_type_node
),
9054 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9055 gfc_add_modify (block
, lse
.expr
, tmp
);
9059 tmp
= build_call_expr_loc (input_location
,
9060 builtin_decl_explicit (BUILT_IN_MALLOC
),
9062 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9063 gfc_add_modify (block
, lse
.expr
, tmp
);
9066 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9068 /* Deferred characters need checking for lhs and rhs string
9069 length. Other deferred parameter variables will have to
9071 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9072 gfc_add_expr_to_block (block
, tmp
);
9074 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9075 gfc_add_expr_to_block (block
, tmp
);
9077 /* For a deferred length character, reallocate if lengths of lhs and
9078 rhs are different. */
9079 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9081 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9082 lse
.string_length
, size
);
9083 /* Jump past the realloc if the lengths are the same. */
9084 tmp
= build3_v (COND_EXPR
, cond
,
9085 build1_v (GOTO_EXPR
, jump_label2
),
9086 build_empty_stmt (input_location
));
9087 gfc_add_expr_to_block (block
, tmp
);
9088 tmp
= build_call_expr_loc (input_location
,
9089 builtin_decl_explicit (BUILT_IN_REALLOC
),
9090 2, fold_convert (pvoid_type_node
, lse
.expr
),
9092 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9093 gfc_add_modify (block
, lse
.expr
, tmp
);
9094 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9095 gfc_add_expr_to_block (block
, tmp
);
9097 /* Update the lhs character length. */
9098 size
= string_length
;
9099 gfc_add_modify (block
, lse
.string_length
, size
);
9103 /* Check for assignments of the type
9107 to make sure we do not check for reallocation unneccessarily. */
9111 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9113 gfc_actual_arglist
*a
;
9116 switch (expr2
->expr_type
)
9119 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9122 if (expr2
->value
.function
.esym
9123 && expr2
->value
.function
.esym
->attr
.elemental
)
9125 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9128 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9133 else if (expr2
->value
.function
.isym
9134 && expr2
->value
.function
.isym
->elemental
)
9136 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9139 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9148 switch (expr2
->value
.op
.op
)
9151 case INTRINSIC_UPLUS
:
9152 case INTRINSIC_UMINUS
:
9153 case INTRINSIC_PARENTHESES
:
9154 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9156 case INTRINSIC_PLUS
:
9157 case INTRINSIC_MINUS
:
9158 case INTRINSIC_TIMES
:
9159 case INTRINSIC_DIVIDE
:
9160 case INTRINSIC_POWER
:
9164 case INTRINSIC_NEQV
:
9171 case INTRINSIC_EQ_OS
:
9172 case INTRINSIC_NE_OS
:
9173 case INTRINSIC_GT_OS
:
9174 case INTRINSIC_GE_OS
:
9175 case INTRINSIC_LT_OS
:
9176 case INTRINSIC_LE_OS
:
9178 e1
= expr2
->value
.op
.op1
;
9179 e2
= expr2
->value
.op
.op2
;
9181 if (e1
->rank
== 0 && e2
->rank
> 0)
9182 return is_runtime_conformable (expr1
, e2
);
9183 else if (e1
->rank
> 0 && e2
->rank
== 0)
9184 return is_runtime_conformable (expr1
, e1
);
9185 else if (e1
->rank
> 0 && e2
->rank
> 0)
9186 return is_runtime_conformable (expr1
, e1
)
9187 && is_runtime_conformable (expr1
, e2
);
9203 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9204 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9205 init_flag indicates initialization expressions and dealloc that no
9206 deallocate prior assignment is needed (if in doubt, set true). */
9209 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9215 gfc_ss
*lss_section
;
9222 bool scalar_to_array
;
9225 bool maybe_workshare
= false;
9227 /* Assignment of the form lhs = rhs. */
9228 gfc_start_block (&block
);
9230 gfc_init_se (&lse
, NULL
);
9231 gfc_init_se (&rse
, NULL
);
9234 lss
= gfc_walk_expr (expr1
);
9235 if (gfc_is_reallocatable_lhs (expr1
)
9236 && !(expr2
->expr_type
== EXPR_FUNCTION
9237 && expr2
->value
.function
.isym
!= NULL
))
9238 lss
->is_alloc_lhs
= 1;
9241 if ((expr1
->ts
.type
== BT_DERIVED
)
9242 && (gfc_is_alloc_class_array_function (expr2
)
9243 || gfc_is_alloc_class_scalar_function (expr2
)))
9244 expr2
->must_finalize
= 1;
9246 if (lss
!= gfc_ss_terminator
)
9248 /* The assignment needs scalarization. */
9251 /* Find a non-scalar SS from the lhs. */
9252 while (lss_section
!= gfc_ss_terminator
9253 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9254 lss_section
= lss_section
->next
;
9256 gcc_assert (lss_section
!= gfc_ss_terminator
);
9258 /* Initialize the scalarizer. */
9259 gfc_init_loopinfo (&loop
);
9262 rss
= gfc_walk_expr (expr2
);
9263 if (rss
== gfc_ss_terminator
)
9264 /* The rhs is scalar. Add a ss for the expression. */
9265 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9267 /* Associate the SS with the loop. */
9268 gfc_add_ss_to_loop (&loop
, lss
);
9269 gfc_add_ss_to_loop (&loop
, rss
);
9271 /* Calculate the bounds of the scalarization. */
9272 gfc_conv_ss_startstride (&loop
);
9273 /* Enable loop reversal. */
9274 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9275 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9276 /* Resolve any data dependencies in the statement. */
9277 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9278 /* Setup the scalarizing loops. */
9279 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9281 /* Setup the gfc_se structures. */
9282 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9283 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9286 gfc_mark_ss_chain_used (rss
, 1);
9287 if (loop
.temp_ss
== NULL
)
9290 gfc_mark_ss_chain_used (lss
, 1);
9294 lse
.ss
= loop
.temp_ss
;
9295 gfc_mark_ss_chain_used (lss
, 3);
9296 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9299 /* Allow the scalarizer to workshare array assignments. */
9300 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
9301 == OMPWS_WORKSHARE_FLAG
9302 && loop
.temp_ss
== NULL
)
9304 maybe_workshare
= true;
9305 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
9308 /* Start the scalarized loop body. */
9309 gfc_start_scalarized_body (&loop
, &body
);
9312 gfc_init_block (&body
);
9314 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9316 /* Translate the expression. */
9317 gfc_conv_expr (&rse
, expr2
);
9319 /* Deal with the case of a scalar class function assigned to a derived type. */
9320 if (gfc_is_alloc_class_scalar_function (expr2
)
9321 && expr1
->ts
.type
== BT_DERIVED
)
9323 rse
.expr
= gfc_class_data_get (rse
.expr
);
9324 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9327 /* Stabilize a string length for temporaries. */
9328 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr1
->ts
.deferred
9329 && !(TREE_CODE (rse
.string_length
) == VAR_DECL
9330 || TREE_CODE (rse
.string_length
) == PARM_DECL
9331 || TREE_CODE (rse
.string_length
) == INDIRECT_REF
))
9332 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9333 else if (expr2
->ts
.type
== BT_CHARACTER
)
9334 string_length
= rse
.string_length
;
9336 string_length
= NULL_TREE
;
9340 gfc_conv_tmp_array_ref (&lse
);
9341 if (expr2
->ts
.type
== BT_CHARACTER
)
9342 lse
.string_length
= string_length
;
9346 gfc_conv_expr (&lse
, expr1
);
9347 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
9349 && gfc_expr_attr (expr1
).allocatable
9356 /* We should only get array references here. */
9357 gcc_assert (TREE_CODE (lse
.expr
) == POINTER_PLUS_EXPR
9358 || TREE_CODE (lse
.expr
) == ARRAY_REF
);
9360 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
9361 or the array itself(ARRAY_REF). */
9362 tmp
= TREE_OPERAND (lse
.expr
, 0);
9364 /* Provide the address of the array. */
9365 if (TREE_CODE (lse
.expr
) == ARRAY_REF
)
9366 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
9368 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9369 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
9370 msg
= _("Assignment of scalar to unallocated array");
9371 gfc_trans_runtime_check (true, false, cond
, &loop
.pre
,
9372 &expr1
->where
, msg
);
9376 /* Assignments of scalar derived types with allocatable components
9377 to arrays must be done with a deep copy and the rhs temporary
9378 must have its components deallocated afterwards. */
9379 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9380 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9381 && !gfc_expr_is_variable (expr2
)
9382 && expr1
->rank
&& !expr2
->rank
);
9383 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9385 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9386 && gfc_is_alloc_class_scalar_function (expr2
));
9387 if (scalar_to_array
&& dealloc
)
9389 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9390 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9393 /* When assigning a character function result to a deferred-length variable,
9394 the function call must happen before the (re)allocation of the lhs -
9395 otherwise the character length of the result is not known.
9396 NOTE: This relies on having the exact dependence of the length type
9397 parameter available to the caller; gfortran saves it in the .mod files.
9398 NOTE ALSO: The concatenation operation generates a temporary pointer,
9399 whose allocation must go to the innermost loop. */
9400 if (flag_realloc_lhs
9401 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
9402 && !(lss
!= gfc_ss_terminator
9403 && expr2
->expr_type
== EXPR_OP
9404 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))
9405 gfc_add_block_to_block (&block
, &rse
.pre
);
9407 /* Nullify the allocatable components corresponding to those of the lhs
9408 derived type, so that the finalization of the function result does not
9409 affect the lhs of the assignment. Prepend is used to ensure that the
9410 nullification occurs before the call to the finalizer. In the case of
9411 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9412 as part of the deep copy. */
9413 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9414 && (gfc_is_alloc_class_array_function (expr2
)
9415 || gfc_is_alloc_class_scalar_function (expr2
)))
9418 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9419 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9420 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9421 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9424 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9425 gfc_expr_is_variable (expr2
) || scalar_to_array
9426 || expr2
->expr_type
== EXPR_ARRAY
,
9427 !(l_is_temp
|| init_flag
) && dealloc
);
9428 gfc_add_expr_to_block (&body
, tmp
);
9430 if (lss
== gfc_ss_terminator
)
9432 /* F2003: Add the code for reallocation on assignment. */
9433 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9434 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9437 /* Use the scalar assignment as is. */
9438 gfc_add_block_to_block (&block
, &body
);
9442 gcc_assert (lse
.ss
== gfc_ss_terminator
9443 && rse
.ss
== gfc_ss_terminator
);
9447 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9449 /* We need to copy the temporary to the actual lhs. */
9450 gfc_init_se (&lse
, NULL
);
9451 gfc_init_se (&rse
, NULL
);
9452 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9453 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9455 rse
.ss
= loop
.temp_ss
;
9458 gfc_conv_tmp_array_ref (&rse
);
9459 gfc_conv_expr (&lse
, expr1
);
9461 gcc_assert (lse
.ss
== gfc_ss_terminator
9462 && rse
.ss
== gfc_ss_terminator
);
9464 if (expr2
->ts
.type
== BT_CHARACTER
)
9465 rse
.string_length
= string_length
;
9467 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9469 gfc_add_expr_to_block (&body
, tmp
);
9472 /* F2003: Allocate or reallocate lhs of allocatable array. */
9473 if (flag_realloc_lhs
9474 && gfc_is_reallocatable_lhs (expr1
)
9475 && !gfc_expr_attr (expr1
).codimension
9476 && !gfc_is_coindexed (expr1
)
9478 && !is_runtime_conformable (expr1
, expr2
))
9480 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9481 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9482 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9483 if (tmp
!= NULL_TREE
)
9484 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9487 if (maybe_workshare
)
9488 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
9490 /* Generate the copying loops. */
9491 gfc_trans_scalarizing_loops (&loop
, &body
);
9493 /* Wrap the whole thing up. */
9494 gfc_add_block_to_block (&block
, &loop
.pre
);
9495 gfc_add_block_to_block (&block
, &loop
.post
);
9497 gfc_cleanup_loop (&loop
);
9500 return gfc_finish_block (&block
);
9504 /* Check whether EXPR is a copyable array. */
9507 copyable_array_p (gfc_expr
* expr
)
9509 if (expr
->expr_type
!= EXPR_VARIABLE
)
9512 /* First check it's an array. */
9513 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9516 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9519 /* Next check that it's of a simple enough type. */
9520 switch (expr
->ts
.type
)
9532 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9541 /* Translate an assignment. */
9544 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9549 /* Special case a single function returning an array. */
9550 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9552 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9557 /* Special case assigning an array to zero. */
9558 if (copyable_array_p (expr1
)
9559 && is_zero_initializer_p (expr2
))
9561 tmp
= gfc_trans_zero_assign (expr1
);
9566 /* Special case copying one array to another. */
9567 if (copyable_array_p (expr1
)
9568 && copyable_array_p (expr2
)
9569 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9570 && !gfc_check_dependency (expr1
, expr2
, 0))
9572 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9577 /* Special case initializing an array from a constant array constructor. */
9578 if (copyable_array_p (expr1
)
9579 && expr2
->expr_type
== EXPR_ARRAY
9580 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9582 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9587 /* Fallback to the scalarizer to generate explicit loops. */
9588 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9592 gfc_trans_init_assign (gfc_code
* code
)
9594 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9598 gfc_trans_assign (gfc_code
* code
)
9600 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);