1 /* Expression translation
2 Copyright (C) 2002-2015 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 /* Get the specified FIELD from the VPTR. */
179 vptr_field_get (tree vptr
, int fieldno
)
182 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
183 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
185 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
186 TREE_TYPE (field
), vptr
, field
,
193 /* Get the field from the class' vptr. */
196 class_vtab_field_get (tree decl
, int fieldno
)
199 vptr
= gfc_class_vptr_get (decl
);
200 return vptr_field_get (vptr
, fieldno
);
204 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
206 #define VTAB_GET_FIELD_GEN(name, field) tree \
207 gfc_class_vtab_## name ##_get (tree cl) \
209 return class_vtab_field_get (cl, field); \
213 gfc_vptr_## name ##_get (tree vptr) \
215 return vptr_field_get (vptr, field); \
218 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
219 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
220 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
221 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
222 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
225 /* The size field is returned as an array index type. Therefore treat
226 it and only it specially. */
229 gfc_class_vtab_size_get (tree cl
)
232 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
233 /* Always return size as an array index type. */
234 size
= fold_convert (gfc_array_index_type
, size
);
240 gfc_vptr_size_get (tree vptr
)
243 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
244 /* Always return size as an array index type. */
245 size
= fold_convert (gfc_array_index_type
, size
);
251 #undef CLASS_DATA_FIELD
252 #undef CLASS_VPTR_FIELD
253 #undef VTABLE_HASH_FIELD
254 #undef VTABLE_SIZE_FIELD
255 #undef VTABLE_EXTENDS_FIELD
256 #undef VTABLE_DEF_INIT_FIELD
257 #undef VTABLE_COPY_FIELD
258 #undef VTABLE_FINAL_FIELD
261 /* Search for the last _class ref in the chain of references of this
262 expression and cut the chain there. Albeit this routine is similiar
263 to class.c::gfc_add_component_ref (), is there a significant
264 difference: gfc_add_component_ref () concentrates on an array ref to
265 be the last ref in the chain. This routine is oblivious to the kind
266 of refs following. */
269 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
272 gfc_ref
*ref
, *class_ref
, *tail
, *array_ref
;
274 /* Find the last class reference. */
277 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
279 if (ref
->type
== REF_ARRAY
280 && ref
->u
.ar
.type
!= AR_ELEMENT
)
283 if (ref
->type
== REF_COMPONENT
284 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
286 /* Component to the right of a part reference with nonzero rank
287 must not have the ALLOCATABLE attribute. If attempts are
288 made to reference such a component reference, an error results
289 followed by anICE. */
291 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
296 if (ref
->next
== NULL
)
300 /* Remove and store all subsequent references after the
304 tail
= class_ref
->next
;
305 class_ref
->next
= NULL
;
313 base_expr
= gfc_expr_to_initialize (e
);
315 /* Restore the original tail expression. */
318 gfc_free_ref_list (class_ref
->next
);
319 class_ref
->next
= tail
;
323 gfc_free_ref_list (e
->ref
);
330 /* Reset the vptr to the declared type, e.g. after deallocation. */
333 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
340 /* Evaluate the expression and obtain the vptr from it. */
341 gfc_init_se (&se
, NULL
);
343 gfc_conv_expr_descriptor (&se
, e
);
345 gfc_conv_expr (&se
, e
);
346 gfc_add_block_to_block (block
, &se
.pre
);
347 vptr
= gfc_get_vptr_from_expr (se
.expr
);
349 /* If a vptr is not found, we can do nothing more. */
350 if (vptr
== NULL_TREE
)
353 if (UNLIMITED_POLY (e
))
354 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
357 /* Return the vptr to the address of the declared type. */
358 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
359 vtable
= vtab
->backend_decl
;
360 if (vtable
== NULL_TREE
)
361 vtable
= gfc_get_symbol_decl (vtab
);
362 vtable
= gfc_build_addr_expr (NULL
, vtable
);
363 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
364 gfc_add_modify (block
, vptr
, vtable
);
369 /* Reset the len for unlimited polymorphic objects. */
372 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
376 e
= gfc_find_and_cut_at_last_class_ref (expr
);
379 gfc_add_len_component (e
);
380 gfc_init_se (&se_len
, NULL
);
381 gfc_conv_expr (&se_len
, e
);
382 gfc_add_modify (block
, se_len
.expr
,
383 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
388 /* Obtain the vptr of the last class reference in an expression.
389 Return NULL_TREE if no class reference is found. */
392 gfc_get_vptr_from_expr (tree expr
)
397 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
399 type
= TREE_TYPE (tmp
);
402 if (GFC_CLASS_TYPE_P (type
))
403 return gfc_class_vptr_get (tmp
);
404 if (type
!= TYPE_CANONICAL (type
))
405 type
= TYPE_CANONICAL (type
);
409 if (TREE_CODE (tmp
) == VAR_DECL
)
417 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
420 tree tmp
, tmp2
, type
;
422 gfc_conv_descriptor_data_set (block
, lhs_desc
,
423 gfc_conv_descriptor_data_get (rhs_desc
));
424 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
425 gfc_conv_descriptor_offset_get (rhs_desc
));
427 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
428 gfc_conv_descriptor_dtype (rhs_desc
));
430 /* Assign the dimension as range-ref. */
431 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
432 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
434 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
435 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
436 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
437 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
438 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
439 gfc_add_modify (block
, tmp
, tmp2
);
443 /* Takes a derived type expression and returns the address of a temporary
444 class object of the 'declared' type. If vptr is not NULL, this is
445 used for the temporary class object.
446 optional_alloc_ptr is false when the dummy is neither allocatable
447 nor a pointer; that's only relevant for the optional handling. */
449 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
450 gfc_typespec class_ts
, tree vptr
, bool optional
,
451 bool optional_alloc_ptr
)
454 tree cond_optional
= NULL_TREE
;
460 /* The derived type needs to be converted to a temporary
462 tmp
= gfc_typenode_for_spec (&class_ts
);
463 var
= gfc_create_var (tmp
, "class");
466 ctree
= gfc_class_vptr_get (var
);
468 if (vptr
!= NULL_TREE
)
470 /* Use the dynamic vptr. */
475 /* In this case the vtab corresponds to the derived type and the
476 vptr must point to it. */
477 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
479 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
481 gfc_add_modify (&parmse
->pre
, ctree
,
482 fold_convert (TREE_TYPE (ctree
), tmp
));
484 /* Now set the data field. */
485 ctree
= gfc_class_data_get (var
);
488 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
490 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
492 /* For an array reference in an elemental procedure call we need
493 to retain the ss to provide the scalarized array reference. */
494 gfc_conv_expr_reference (parmse
, e
);
495 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
497 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
499 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
500 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
505 ss
= gfc_walk_expr (e
);
506 if (ss
== gfc_ss_terminator
)
509 gfc_conv_expr_reference (parmse
, e
);
511 /* Scalar to an assumed-rank array. */
512 if (class_ts
.u
.derived
->components
->as
)
515 type
= get_scalar_to_descriptor_type (parmse
->expr
,
517 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
518 gfc_get_dtype (type
));
520 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
521 TREE_TYPE (parmse
->expr
),
522 cond_optional
, parmse
->expr
,
523 fold_convert (TREE_TYPE (parmse
->expr
),
525 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
529 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
531 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
533 fold_convert (TREE_TYPE (tmp
),
535 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
541 gfc_init_block (&block
);
544 gfc_conv_expr_descriptor (parmse
, e
);
546 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
548 gcc_assert (class_ts
.u
.derived
->components
->as
->type
550 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
554 if (gfc_expr_attr (e
).codimension
)
555 parmse
->expr
= fold_build1_loc (input_location
,
559 gfc_add_modify (&block
, ctree
, parmse
->expr
);
564 tmp
= gfc_finish_block (&block
);
566 gfc_init_block (&block
);
567 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
569 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
570 gfc_finish_block (&block
));
571 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
574 gfc_add_block_to_block (&parmse
->pre
, &block
);
578 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
579 && class_ts
.u
.derived
->components
->ts
.u
.derived
580 ->attr
.unlimited_polymorphic
)
582 /* Take care about initializing the _len component correctly. */
583 ctree
= gfc_class_len_get (var
);
584 if (UNLIMITED_POLY (e
))
589 len
= gfc_copy_expr (e
);
590 gfc_add_len_component (len
);
591 gfc_init_se (&se
, NULL
);
592 gfc_conv_expr (&se
, len
);
594 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
595 cond_optional
, se
.expr
,
596 fold_convert (TREE_TYPE (se
.expr
),
602 tmp
= integer_zero_node
;
603 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
606 /* Pass the address of the class object. */
607 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
609 if (optional
&& optional_alloc_ptr
)
610 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
611 TREE_TYPE (parmse
->expr
),
612 cond_optional
, parmse
->expr
,
613 fold_convert (TREE_TYPE (parmse
->expr
),
618 /* Create a new class container, which is required as scalar coarrays
619 have an array descriptor while normal scalars haven't. Optionally,
620 NULL pointer checks are added if the argument is OPTIONAL. */
623 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
624 gfc_typespec class_ts
, bool optional
)
626 tree var
, ctree
, tmp
;
631 gfc_init_block (&block
);
634 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
636 if (ref
->type
== REF_COMPONENT
637 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
641 if (class_ref
== NULL
642 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
643 tmp
= e
->symtree
->n
.sym
->backend_decl
;
646 /* Remove everything after the last class reference, convert the
647 expression and then recover its tailend once more. */
649 ref
= class_ref
->next
;
650 class_ref
->next
= NULL
;
651 gfc_init_se (&tmpse
, NULL
);
652 gfc_conv_expr (&tmpse
, e
);
653 class_ref
->next
= ref
;
657 var
= gfc_typenode_for_spec (&class_ts
);
658 var
= gfc_create_var (var
, "class");
660 ctree
= gfc_class_vptr_get (var
);
661 gfc_add_modify (&block
, ctree
,
662 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
664 ctree
= gfc_class_data_get (var
);
665 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
666 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
668 /* Pass the address of the class object. */
669 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
673 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
676 tmp
= gfc_finish_block (&block
);
678 gfc_init_block (&block
);
679 tmp2
= gfc_class_data_get (var
);
680 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
682 tmp2
= gfc_finish_block (&block
);
684 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
686 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
689 gfc_add_block_to_block (&parmse
->pre
, &block
);
693 /* Takes an intrinsic type expression and returns the address of a temporary
694 class object of the 'declared' type. */
696 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
697 gfc_typespec class_ts
)
705 /* The intrinsic type needs to be converted to a temporary
707 tmp
= gfc_typenode_for_spec (&class_ts
);
708 var
= gfc_create_var (tmp
, "class");
711 ctree
= gfc_class_vptr_get (var
);
713 vtab
= gfc_find_vtab (&e
->ts
);
715 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
716 gfc_add_modify (&parmse
->pre
, ctree
,
717 fold_convert (TREE_TYPE (ctree
), tmp
));
719 /* Now set the data field. */
720 ctree
= gfc_class_data_get (var
);
721 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
723 /* For an array reference in an elemental procedure call we need
724 to retain the ss to provide the scalarized array reference. */
725 gfc_conv_expr_reference (parmse
, e
);
726 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
727 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
731 ss
= gfc_walk_expr (e
);
732 if (ss
== gfc_ss_terminator
)
735 gfc_conv_expr_reference (parmse
, e
);
736 if (class_ts
.u
.derived
->components
->as
737 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
739 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
741 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
742 TREE_TYPE (ctree
), tmp
);
745 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
746 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
751 parmse
->use_offset
= 1;
752 gfc_conv_expr_descriptor (parmse
, e
);
753 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
755 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
756 TREE_TYPE (ctree
), parmse
->expr
);
757 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
760 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
764 gcc_assert (class_ts
.type
== BT_CLASS
);
765 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
766 && class_ts
.u
.derived
->components
->ts
.u
.derived
767 ->attr
.unlimited_polymorphic
)
769 ctree
= gfc_class_len_get (var
);
770 /* When the actual arg is a char array, then set the _len component of the
771 unlimited polymorphic entity, too. */
772 if (e
->ts
.type
== BT_CHARACTER
)
774 /* Start with parmse->string_length because this seems to be set to a
775 correct value more often. */
776 if (parmse
->string_length
)
777 tmp
= parmse
->string_length
;
778 /* When the string_length is not yet set, then try the backend_decl of
780 else if (e
->ts
.u
.cl
->backend_decl
)
781 tmp
= e
->ts
.u
.cl
->backend_decl
;
782 /* If both of the above approaches fail, then try to generate an
783 expression from the input, which is only feasible currently, when the
784 expression can be evaluated to a constant one. */
787 /* Try to simplify the expression. */
788 gfc_simplify_expr (e
, 0);
789 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
791 /* Amazingly all data is present to compute the length of a
792 constant string, but the expression is not yet there. */
793 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
795 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
796 e
->value
.character
.length
);
797 gfc_conv_const_charlen (e
->ts
.u
.cl
);
798 e
->ts
.u
.cl
->resolved
= 1;
799 tmp
= e
->ts
.u
.cl
->backend_decl
;
803 gfc_error ("Can't compute the length of the char array at %L.",
809 tmp
= integer_zero_node
;
811 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
813 else if (class_ts
.type
== BT_CLASS
814 && class_ts
.u
.derived
->components
815 && class_ts
.u
.derived
->components
->ts
.u
816 .derived
->attr
.unlimited_polymorphic
)
818 ctree
= gfc_class_len_get (var
);
819 gfc_add_modify (&parmse
->pre
, ctree
,
820 fold_convert (TREE_TYPE (ctree
),
823 /* Pass the address of the class object. */
824 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
828 /* Takes a scalarized class array expression and returns the
829 address of a temporary scalar class object of the 'declared'
831 OOP-TODO: This could be improved by adding code that branched on
832 the dynamic type being the same as the declared type. In this case
833 the original class expression can be passed directly.
834 optional_alloc_ptr is false when the dummy is neither allocatable
835 nor a pointer; that's relevant for the optional handling.
836 Set copyback to true if class container's _data and _vtab pointers
837 might get modified. */
840 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
841 bool elemental
, bool copyback
, bool optional
,
842 bool optional_alloc_ptr
)
848 tree cond
= NULL_TREE
;
849 tree slen
= NULL_TREE
;
853 bool full_array
= false;
855 gfc_init_block (&block
);
858 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
860 if (ref
->type
== REF_COMPONENT
861 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
864 if (ref
->next
== NULL
)
868 if ((ref
== NULL
|| class_ref
== ref
)
869 && (!class_ts
.u
.derived
->components
->as
870 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
873 /* Test for FULL_ARRAY. */
874 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
875 && gfc_expr_attr (e
).dimension
)
878 gfc_is_class_array_ref (e
, &full_array
);
880 /* The derived type needs to be converted to a temporary
882 tmp
= gfc_typenode_for_spec (&class_ts
);
883 var
= gfc_create_var (tmp
, "class");
886 ctree
= gfc_class_data_get (var
);
887 if (class_ts
.u
.derived
->components
->as
888 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
892 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
894 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
895 gfc_get_dtype (type
));
897 tmp
= gfc_class_data_get (parmse
->expr
);
898 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
899 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
901 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
904 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
908 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
909 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
910 TREE_TYPE (ctree
), parmse
->expr
);
911 gfc_add_modify (&block
, ctree
, parmse
->expr
);
914 /* Return the data component, except in the case of scalarized array
915 references, where nullification of the cannot occur and so there
917 if (!elemental
&& full_array
&& copyback
)
919 if (class_ts
.u
.derived
->components
->as
920 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
923 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
924 gfc_conv_descriptor_data_get (ctree
));
926 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
929 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
933 ctree
= gfc_class_vptr_get (var
);
935 /* The vptr is the second field of the actual argument.
936 First we have to find the corresponding class reference. */
939 if (class_ref
== NULL
940 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
942 tmp
= e
->symtree
->n
.sym
->backend_decl
;
943 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
944 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
945 slen
= integer_zero_node
;
949 /* Remove everything after the last class reference, convert the
950 expression and then recover its tailend once more. */
952 ref
= class_ref
->next
;
953 class_ref
->next
= NULL
;
954 gfc_init_se (&tmpse
, NULL
);
955 gfc_conv_expr (&tmpse
, e
);
956 class_ref
->next
= ref
;
958 slen
= tmpse
.string_length
;
961 gcc_assert (tmp
!= NULL_TREE
);
963 /* Dereference if needs be. */
964 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
965 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
967 vptr
= gfc_class_vptr_get (tmp
);
968 gfc_add_modify (&block
, ctree
,
969 fold_convert (TREE_TYPE (ctree
), vptr
));
971 /* Return the vptr component, except in the case of scalarized array
972 references, where the dynamic type cannot change. */
973 if (!elemental
&& full_array
&& copyback
)
974 gfc_add_modify (&parmse
->post
, vptr
,
975 fold_convert (TREE_TYPE (vptr
), ctree
));
977 /* For unlimited polymorphic objects also set the _len component. */
978 if (class_ts
.type
== BT_CLASS
979 && class_ts
.u
.derived
->components
980 && class_ts
.u
.derived
->components
->ts
.u
981 .derived
->attr
.unlimited_polymorphic
)
983 ctree
= gfc_class_len_get (var
);
984 if (UNLIMITED_POLY (e
))
985 tmp
= gfc_class_len_get (tmp
);
986 else if (e
->ts
.type
== BT_CHARACTER
)
988 gcc_assert (slen
!= NULL_TREE
);
992 tmp
= integer_zero_node
;
993 gfc_add_modify (&parmse
->pre
, ctree
,
994 fold_convert (TREE_TYPE (ctree
), tmp
));
1001 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1002 /* parmse->pre may contain some preparatory instructions for the
1003 temporary array descriptor. Those may only be executed when the
1004 optional argument is set, therefore add parmse->pre's instructions
1005 to block, which is later guarded by an if (optional_arg_given). */
1006 gfc_add_block_to_block (&parmse
->pre
, &block
);
1007 block
.head
= parmse
->pre
.head
;
1008 parmse
->pre
.head
= NULL_TREE
;
1009 tmp
= gfc_finish_block (&block
);
1011 if (optional_alloc_ptr
)
1012 tmp2
= build_empty_stmt (input_location
);
1015 gfc_init_block (&block
);
1017 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1018 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1019 null_pointer_node
));
1020 tmp2
= gfc_finish_block (&block
);
1023 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1025 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1028 gfc_add_block_to_block (&parmse
->pre
, &block
);
1030 /* Pass the address of the class object. */
1031 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1033 if (optional
&& optional_alloc_ptr
)
1034 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1035 TREE_TYPE (parmse
->expr
),
1037 fold_convert (TREE_TYPE (parmse
->expr
),
1038 null_pointer_node
));
1042 /* Given a class array declaration and an index, returns the address
1043 of the referenced element. */
1046 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1048 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1049 gfc_class_data_get (class_decl
);
1050 tree size
= gfc_class_vtab_size_get (class_decl
);
1051 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1052 gfc_array_index_type
,
1055 data
= gfc_conv_descriptor_data_get (data
);
1056 ptr
= fold_convert (pvoid_type_node
, data
);
1057 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1058 return fold_convert (TREE_TYPE (data
), ptr
);
1062 /* Copies one class expression to another, assuming that if either
1063 'to' or 'from' are arrays they are packed. Should 'from' be
1064 NULL_TREE, the initialization expression for 'to' is used, assuming
1065 that the _vptr is set. */
1068 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1078 vec
<tree
, va_gc
> *args
;
1083 bool is_from_desc
= false, is_to_class
= false;
1086 /* To prevent warnings on uninitialized variables. */
1087 from_len
= to_len
= NULL_TREE
;
1089 if (from
!= NULL_TREE
)
1090 fcn
= gfc_class_vtab_copy_get (from
);
1092 fcn
= gfc_class_vtab_copy_get (to
);
1094 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1096 if (from
!= NULL_TREE
)
1098 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1102 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1106 from_data
= gfc_class_data_get (from
);
1107 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1111 from_data
= gfc_class_vtab_def_init_get (to
);
1115 if (from
!= NULL_TREE
&& unlimited
)
1116 from_len
= gfc_class_len_get (from
);
1118 from_len
= integer_zero_node
;
1121 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1124 to_data
= gfc_class_data_get (to
);
1126 to_len
= gfc_class_len_get (to
);
1129 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1132 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1134 stmtblock_t loopbody
;
1139 gfc_init_block (&body
);
1140 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1141 gfc_array_index_type
, nelems
,
1142 gfc_index_one_node
);
1143 nelems
= gfc_evaluate_now (tmp
, &body
);
1144 index
= gfc_create_var (gfc_array_index_type
, "S");
1148 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1149 vec_safe_push (args
, from_ref
);
1152 vec_safe_push (args
, from_data
);
1155 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1158 tmp
= gfc_conv_array_data (to
);
1159 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1160 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1161 gfc_build_array_ref (tmp
, index
, to
));
1163 vec_safe_push (args
, to_ref
);
1165 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1167 /* Build the body of the loop. */
1168 gfc_init_block (&loopbody
);
1169 gfc_add_expr_to_block (&loopbody
, tmp
);
1171 /* Build the loop and return. */
1172 gfc_init_loopinfo (&loop
);
1174 loop
.from
[0] = gfc_index_zero_node
;
1175 loop
.loopvar
[0] = index
;
1176 loop
.to
[0] = nelems
;
1177 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1178 gfc_init_block (&ifbody
);
1179 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1180 stdcopy
= gfc_finish_block (&ifbody
);
1181 /* In initialization mode from_len is a constant zero. */
1182 if (unlimited
&& !integer_zerop (from_len
))
1184 vec_safe_push (args
, from_len
);
1185 vec_safe_push (args
, to_len
);
1186 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1187 /* Build the body of the loop. */
1188 gfc_init_block (&loopbody
);
1189 gfc_add_expr_to_block (&loopbody
, tmp
);
1191 /* Build the loop and return. */
1192 gfc_init_loopinfo (&loop
);
1194 loop
.from
[0] = gfc_index_zero_node
;
1195 loop
.loopvar
[0] = index
;
1196 loop
.to
[0] = nelems
;
1197 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1198 gfc_init_block (&ifbody
);
1199 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1200 extcopy
= gfc_finish_block (&ifbody
);
1202 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1203 boolean_type_node
, from_len
,
1205 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1206 void_type_node
, tmp
, extcopy
, stdcopy
);
1207 gfc_add_expr_to_block (&body
, tmp
);
1208 tmp
= gfc_finish_block (&body
);
1212 gfc_add_expr_to_block (&body
, stdcopy
);
1213 tmp
= gfc_finish_block (&body
);
1215 gfc_cleanup_loop (&loop
);
1219 gcc_assert (!is_from_desc
);
1220 vec_safe_push (args
, from_data
);
1221 vec_safe_push (args
, to_data
);
1222 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1224 /* In initialization mode from_len is a constant zero. */
1225 if (unlimited
&& !integer_zerop (from_len
))
1227 vec_safe_push (args
, from_len
);
1228 vec_safe_push (args
, to_len
);
1229 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1230 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1231 boolean_type_node
, from_len
,
1233 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1234 void_type_node
, tmp
, extcopy
, stdcopy
);
1240 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1241 if (from
== NULL_TREE
)
1244 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1246 from_data
, null_pointer_node
);
1247 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1248 void_type_node
, cond
,
1249 tmp
, build_empty_stmt (input_location
));
1257 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1259 gfc_actual_arglist
*actual
;
1264 actual
= gfc_get_actual_arglist ();
1265 actual
->expr
= gfc_copy_expr (rhs
);
1266 actual
->next
= gfc_get_actual_arglist ();
1267 actual
->next
->expr
= gfc_copy_expr (lhs
);
1268 ppc
= gfc_copy_expr (obj
);
1269 gfc_add_vptr_component (ppc
);
1270 gfc_add_component_ref (ppc
, "_copy");
1271 ppc_code
= gfc_get_code (EXEC_CALL
);
1272 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1273 /* Although '_copy' is set to be elemental in class.c, it is
1274 not staying that way. Find out why, sometime.... */
1275 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1276 ppc_code
->ext
.actual
= actual
;
1277 ppc_code
->expr1
= ppc
;
1278 /* Since '_copy' is elemental, the scalarizer will take care
1279 of arrays in gfc_trans_call. */
1280 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1281 gfc_free_statements (ppc_code
);
1283 if (UNLIMITED_POLY(obj
))
1285 /* Check if rhs is non-NULL. */
1287 gfc_init_se (&src
, NULL
);
1288 gfc_conv_expr (&src
, rhs
);
1289 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1290 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1291 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1292 null_pointer_node
));
1293 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1294 build_empty_stmt (input_location
));
1300 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1301 A MEMCPY is needed to copy the full data from the default initializer
1302 of the dynamic type. */
1305 gfc_trans_class_init_assign (gfc_code
*code
)
1309 gfc_se dst
,src
,memsz
;
1310 gfc_expr
*lhs
, *rhs
, *sz
;
1312 gfc_start_block (&block
);
1314 lhs
= gfc_copy_expr (code
->expr1
);
1315 gfc_add_data_component (lhs
);
1317 rhs
= gfc_copy_expr (code
->expr1
);
1318 gfc_add_vptr_component (rhs
);
1320 /* Make sure that the component backend_decls have been built, which
1321 will not have happened if the derived types concerned have not
1323 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1324 gfc_add_def_init_component (rhs
);
1325 /* The _def_init is always scalar. */
1328 if (code
->expr1
->ts
.type
== BT_CLASS
1329 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1330 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1333 sz
= gfc_copy_expr (code
->expr1
);
1334 gfc_add_vptr_component (sz
);
1335 gfc_add_size_component (sz
);
1337 gfc_init_se (&dst
, NULL
);
1338 gfc_init_se (&src
, NULL
);
1339 gfc_init_se (&memsz
, NULL
);
1340 gfc_conv_expr (&dst
, lhs
);
1341 gfc_conv_expr (&src
, rhs
);
1342 gfc_conv_expr (&memsz
, sz
);
1343 gfc_add_block_to_block (&block
, &src
.pre
);
1344 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1346 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1348 if (UNLIMITED_POLY(code
->expr1
))
1350 /* Check if _def_init is non-NULL. */
1351 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1352 boolean_type_node
, src
.expr
,
1353 fold_convert (TREE_TYPE (src
.expr
),
1354 null_pointer_node
));
1355 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1356 tmp
, build_empty_stmt (input_location
));
1360 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1361 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1363 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1364 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1366 build_empty_stmt (input_location
));
1369 gfc_add_expr_to_block (&block
, tmp
);
1371 return gfc_finish_block (&block
);
1375 /* Translate an assignment to a CLASS object
1376 (pointer or ordinary assignment). */
1379 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1387 gfc_start_block (&block
);
1390 while (ref
&& ref
->next
)
1393 /* Class valued proc_pointer assignments do not need any further
1395 if (ref
&& ref
->type
== REF_COMPONENT
1396 && ref
->u
.c
.component
->attr
.proc_pointer
1397 && expr2
->expr_type
== EXPR_VARIABLE
1398 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1399 && op
== EXEC_POINTER_ASSIGN
)
1402 if (expr2
->ts
.type
!= BT_CLASS
)
1404 /* Insert an additional assignment which sets the '_vptr' field. */
1405 gfc_symbol
*vtab
= NULL
;
1408 lhs
= gfc_copy_expr (expr1
);
1409 gfc_add_vptr_component (lhs
);
1411 if (UNLIMITED_POLY (expr1
)
1412 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1414 rhs
= gfc_get_null_expr (&expr2
->where
);
1418 if (expr2
->expr_type
== EXPR_NULL
)
1419 vtab
= gfc_find_vtab (&expr1
->ts
);
1421 vtab
= gfc_find_vtab (&expr2
->ts
);
1424 rhs
= gfc_get_expr ();
1425 rhs
->expr_type
= EXPR_VARIABLE
;
1426 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1430 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1431 gfc_add_expr_to_block (&block
, tmp
);
1433 gfc_free_expr (lhs
);
1434 gfc_free_expr (rhs
);
1436 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1438 /* F2003:C717 only sequence and bind-C types can come here. */
1439 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1440 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1441 gfc_add_data_component (expr2
);
1444 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1446 /* Insert an additional assignment which sets the '_vptr' field. */
1447 lhs
= gfc_copy_expr (expr1
);
1448 gfc_add_vptr_component (lhs
);
1450 rhs
= gfc_copy_expr (expr2
);
1451 gfc_add_vptr_component (rhs
);
1453 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1454 gfc_add_expr_to_block (&block
, tmp
);
1456 gfc_free_expr (lhs
);
1457 gfc_free_expr (rhs
);
1460 /* Do the actual CLASS assignment. */
1461 if (expr2
->ts
.type
== BT_CLASS
1462 && !CLASS_DATA (expr2
)->attr
.dimension
)
1464 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1465 || !CLASS_DATA (expr2
)->attr
.dimension
)
1466 gfc_add_data_component (expr1
);
1470 if (op
== EXEC_ASSIGN
)
1471 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1472 else if (op
== EXEC_POINTER_ASSIGN
)
1473 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1477 gfc_add_expr_to_block (&block
, tmp
);
1479 return gfc_finish_block (&block
);
1483 /* End of prototype trans-class.c */
1487 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1489 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1490 gfc_warning (OPT_Wrealloc_lhs
,
1491 "Code for reallocating the allocatable array at %L will "
1493 else if (warn_realloc_lhs_all
)
1494 gfc_warning (OPT_Wrealloc_lhs_all
,
1495 "Code for reallocating the allocatable variable at %L "
1496 "will be added", where
);
1500 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1503 /* Copy the scalarization loop variables. */
1506 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1509 dest
->loop
= src
->loop
;
1513 /* Initialize a simple expression holder.
1515 Care must be taken when multiple se are created with the same parent.
1516 The child se must be kept in sync. The easiest way is to delay creation
1517 of a child se until after after the previous se has been translated. */
1520 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1522 memset (se
, 0, sizeof (gfc_se
));
1523 gfc_init_block (&se
->pre
);
1524 gfc_init_block (&se
->post
);
1526 se
->parent
= parent
;
1529 gfc_copy_se_loopvars (se
, parent
);
1533 /* Advances to the next SS in the chain. Use this rather than setting
1534 se->ss = se->ss->next because all the parents needs to be kept in sync.
1538 gfc_advance_se_ss_chain (gfc_se
* se
)
1543 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1546 /* Walk down the parent chain. */
1549 /* Simple consistency check. */
1550 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1551 || p
->parent
->ss
->nested_ss
== p
->ss
);
1553 /* If we were in a nested loop, the next scalarized expression can be
1554 on the parent ss' next pointer. Thus we should not take the next
1555 pointer blindly, but rather go up one nest level as long as next
1556 is the end of chain. */
1558 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1568 /* Ensures the result of the expression as either a temporary variable
1569 or a constant so that it can be used repeatedly. */
1572 gfc_make_safe_expr (gfc_se
* se
)
1576 if (CONSTANT_CLASS_P (se
->expr
))
1579 /* We need a temporary for this result. */
1580 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1581 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1586 /* Return an expression which determines if a dummy parameter is present.
1587 Also used for arguments to procedures with multiple entry points. */
1590 gfc_conv_expr_present (gfc_symbol
* sym
)
1594 gcc_assert (sym
->attr
.dummy
);
1595 decl
= gfc_get_symbol_decl (sym
);
1597 /* Intrinsic scalars with VALUE attribute which are passed by value
1598 use a hidden argument to denote the present status. */
1599 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1600 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1601 && !sym
->attr
.dimension
)
1603 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1606 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1608 strcpy (&name
[1], sym
->name
);
1609 tree_name
= get_identifier (name
);
1611 /* Walk function argument list to find hidden arg. */
1612 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1613 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1614 if (DECL_NAME (cond
) == tree_name
)
1621 if (TREE_CODE (decl
) != PARM_DECL
)
1623 /* Array parameters use a temporary descriptor, we want the real
1625 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1626 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1627 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1630 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1631 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1633 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1634 as actual argument to denote absent dummies. For array descriptors,
1635 we thus also need to check the array descriptor. For BT_CLASS, it
1636 can also occur for scalars and F2003 due to type->class wrapping and
1637 class->class wrapping. Note further that BT_CLASS always uses an
1638 array descriptor for arrays, also for explicit-shape/assumed-size. */
1640 if (!sym
->attr
.allocatable
1641 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1642 || (sym
->ts
.type
== BT_CLASS
1643 && !CLASS_DATA (sym
)->attr
.allocatable
1644 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1645 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1646 || sym
->ts
.type
== BT_CLASS
))
1650 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1651 || sym
->as
->type
== AS_ASSUMED_RANK
1652 || sym
->attr
.codimension
))
1653 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1655 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1656 if (sym
->ts
.type
== BT_CLASS
)
1657 tmp
= gfc_class_data_get (tmp
);
1658 tmp
= gfc_conv_array_data (tmp
);
1660 else if (sym
->ts
.type
== BT_CLASS
)
1661 tmp
= gfc_class_data_get (decl
);
1665 if (tmp
!= NULL_TREE
)
1667 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1668 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1669 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1670 boolean_type_node
, cond
, tmp
);
1678 /* Converts a missing, dummy argument into a null or zero. */
1681 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1686 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1690 /* Create a temporary and convert it to the correct type. */
1691 tmp
= gfc_get_int_type (kind
);
1692 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1695 /* Test for a NULL value. */
1696 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1697 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1698 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1699 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1703 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1705 build_zero_cst (TREE_TYPE (se
->expr
)));
1706 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1710 if (ts
.type
== BT_CHARACTER
)
1712 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1713 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1714 present
, se
->string_length
, tmp
);
1715 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1716 se
->string_length
= tmp
;
1722 /* Get the character length of an expression, looking through gfc_refs
1726 gfc_get_expr_charlen (gfc_expr
*e
)
1731 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1732 && e
->ts
.type
== BT_CHARACTER
);
1734 length
= NULL
; /* To silence compiler warning. */
1736 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1739 gfc_init_se (&tmpse
, NULL
);
1740 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1741 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1745 /* First candidate: if the variable is of type CHARACTER, the
1746 expression's length could be the length of the character
1748 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1749 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1751 /* Look through the reference chain for component references. */
1752 for (r
= e
->ref
; r
; r
= r
->next
)
1757 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1758 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1766 /* We should never got substring references here. These will be
1767 broken down by the scalarizer. */
1773 gcc_assert (length
!= NULL
);
1778 /* Return for an expression the backend decl of the coarray. */
1781 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1785 gfc_ref
*ref
, *comp_ref
= NULL
;
1787 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1789 /* Not-implemented diagnostic. */
1790 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1791 if (ref
->type
== REF_COMPONENT
)
1794 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1795 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1796 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1797 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1798 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1799 && !ref
->u
.c
.component
->attr
.codimension
1800 && (ref
->u
.c
.component
->attr
.pointer
1801 || ref
->u
.c
.component
->attr
.allocatable
)))
1802 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1803 "component of the coindexed coarray at %L is not yet "
1804 "supported", &expr
->where
);
1807 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1808 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1809 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1810 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1812 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1813 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1814 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1815 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1816 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1817 "not yet supported", &expr
->where
);
1821 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1822 general not possible as the required stride multiplier might be not
1823 a multiple of c_sizeof(b). In case of noncoindexed access, the
1824 scalarizer often takes care of it - for coarrays, it always fails. */
1825 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1826 if (ref
->type
== REF_COMPONENT
1827 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1828 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1829 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1830 && ref
->u
.c
.component
->attr
.codimension
)))
1834 for ( ; ref
; ref
= ref
->next
)
1835 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1837 for ( ; ref
; ref
= ref
->next
)
1838 if (ref
->type
== REF_COMPONENT
)
1839 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1840 "with an array partref is not yet supported",
1844 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1845 gcc_assert (caf_decl
);
1846 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1847 caf_decl
= gfc_class_data_get (caf_decl
);
1848 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1851 /* The following code assumes that the coarray is a component reachable via
1852 only scalar components/variables; the Fortran standard guarantees this. */
1854 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1855 if (ref
->type
== REF_COMPONENT
)
1857 gfc_component
*comp
= ref
->u
.c
.component
;
1859 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1860 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1861 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1862 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1863 comp
->backend_decl
, NULL_TREE
);
1864 if (comp
->ts
.type
== BT_CLASS
)
1865 caf_decl
= gfc_class_data_get (caf_decl
);
1866 if (comp
->attr
.codimension
)
1872 gcc_assert (found
&& caf_decl
);
1877 /* Obtain the Coarray token - and optionally also the offset. */
1880 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1885 /* Coarray token. */
1886 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1888 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1889 == GFC_ARRAY_ALLOCATABLE
1890 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1891 *token
= gfc_conv_descriptor_token (caf_decl
);
1893 else if (DECL_LANG_SPECIFIC (caf_decl
)
1894 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1895 *token
= GFC_DECL_TOKEN (caf_decl
);
1898 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1899 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1900 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1906 /* Offset between the coarray base address and the address wanted. */
1907 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1908 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1909 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1910 *offset
= build_int_cst (gfc_array_index_type
, 0);
1911 else if (DECL_LANG_SPECIFIC (caf_decl
)
1912 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1913 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1914 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1915 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1917 *offset
= build_int_cst (gfc_array_index_type
, 0);
1919 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1920 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1922 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1923 tmp
= gfc_conv_descriptor_data_get (tmp
);
1925 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1926 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1929 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1933 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1934 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1936 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1937 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1940 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1944 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1945 fold_convert (gfc_array_index_type
, *offset
),
1946 fold_convert (gfc_array_index_type
, tmp
));
1950 /* Convert the coindex of a coarray into an image index; the result is
1951 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1952 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1955 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1958 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1962 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1963 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1965 gcc_assert (ref
!= NULL
);
1967 img_idx
= integer_zero_node
;
1968 extent
= integer_one_node
;
1969 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1970 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1972 gfc_init_se (&se
, NULL
);
1973 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1974 gfc_add_block_to_block (block
, &se
.pre
);
1975 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1976 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1977 integer_type_node
, se
.expr
,
1978 fold_convert(integer_type_node
, lbound
));
1979 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1981 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1983 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1985 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1986 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1987 tmp
= fold_convert (integer_type_node
, tmp
);
1988 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1989 integer_type_node
, extent
, tmp
);
1993 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1995 gfc_init_se (&se
, NULL
);
1996 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1997 gfc_add_block_to_block (block
, &se
.pre
);
1998 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1999 lbound
= fold_convert (integer_type_node
, lbound
);
2000 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2001 integer_type_node
, se
.expr
, lbound
);
2002 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2004 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2006 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2008 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2009 ubound
= fold_convert (integer_type_node
, ubound
);
2010 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2011 integer_type_node
, ubound
, lbound
);
2012 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2013 tmp
, integer_one_node
);
2014 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2015 integer_type_node
, extent
, tmp
);
2018 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2019 img_idx
, integer_one_node
);
2024 /* For each character array constructor subexpression without a ts.u.cl->length,
2025 replace it by its first element (if there aren't any elements, the length
2026 should already be set to zero). */
2029 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2031 gfc_actual_arglist
* arg
;
2037 switch (e
->expr_type
)
2041 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2042 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2046 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2050 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2051 flatten_array_ctors_without_strlen (arg
->expr
);
2056 /* We've found what we're looking for. */
2057 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2062 gcc_assert (e
->value
.constructor
);
2064 c
= gfc_constructor_first (e
->value
.constructor
);
2068 flatten_array_ctors_without_strlen (new_expr
);
2069 gfc_replace_expr (e
, new_expr
);
2073 /* Otherwise, fall through to handle constructor elements. */
2074 case EXPR_STRUCTURE
:
2075 for (c
= gfc_constructor_first (e
->value
.constructor
);
2076 c
; c
= gfc_constructor_next (c
))
2077 flatten_array_ctors_without_strlen (c
->expr
);
2087 /* Generate code to initialize a string length variable. Returns the
2088 value. For array constructors, cl->length might be NULL and in this case,
2089 the first element of the constructor is needed. expr is the original
2090 expression so we can access it but can be NULL if this is not needed. */
2093 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2097 gfc_init_se (&se
, NULL
);
2101 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2104 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2105 "flatten" array constructors by taking their first element; all elements
2106 should be the same length or a cl->length should be present. */
2109 gfc_expr
* expr_flat
;
2111 expr_flat
= gfc_copy_expr (expr
);
2112 flatten_array_ctors_without_strlen (expr_flat
);
2113 gfc_resolve_expr (expr_flat
);
2115 gfc_conv_expr (&se
, expr_flat
);
2116 gfc_add_block_to_block (pblock
, &se
.pre
);
2117 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2119 gfc_free_expr (expr_flat
);
2123 /* Convert cl->length. */
2125 gcc_assert (cl
->length
);
2127 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2128 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2129 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2130 gfc_add_block_to_block (pblock
, &se
.pre
);
2132 if (cl
->backend_decl
)
2133 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2135 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2140 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2141 const char *name
, locus
*where
)
2151 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2152 type
= build_pointer_type (type
);
2154 gfc_init_se (&start
, se
);
2155 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2156 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2158 if (integer_onep (start
.expr
))
2159 gfc_conv_string_parameter (se
);
2164 /* Avoid multiple evaluation of substring start. */
2165 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2166 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2168 /* Change the start of the string. */
2169 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2172 tmp
= build_fold_indirect_ref_loc (input_location
,
2174 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2175 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2178 /* Length = end + 1 - start. */
2179 gfc_init_se (&end
, se
);
2180 if (ref
->u
.ss
.end
== NULL
)
2181 end
.expr
= se
->string_length
;
2184 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2185 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2189 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2190 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2192 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2194 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2195 boolean_type_node
, start
.expr
,
2198 /* Check lower bound. */
2199 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2201 build_int_cst (gfc_charlen_type_node
, 1));
2202 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2203 boolean_type_node
, nonempty
, fault
);
2205 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2206 "is less than one", name
);
2208 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2209 "is less than one");
2210 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2211 fold_convert (long_integer_type_node
,
2215 /* Check upper bound. */
2216 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2217 end
.expr
, se
->string_length
);
2218 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2219 boolean_type_node
, nonempty
, fault
);
2221 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2222 "exceeds string length (%%ld)", name
);
2224 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2225 "exceeds string length (%%ld)");
2226 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2227 fold_convert (long_integer_type_node
, end
.expr
),
2228 fold_convert (long_integer_type_node
,
2229 se
->string_length
));
2233 /* Try to calculate the length from the start and end expressions. */
2235 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2239 i_len
= mpz_get_si (length
) + 1;
2243 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2244 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2248 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2249 end
.expr
, start
.expr
);
2250 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2251 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2252 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2253 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2256 se
->string_length
= tmp
;
2260 /* Convert a derived type component reference. */
2263 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2270 c
= ref
->u
.c
.component
;
2272 if (c
->backend_decl
== NULL_TREE
2273 && ref
->u
.c
.sym
!= NULL
)
2274 gfc_get_derived_type (ref
->u
.c
.sym
);
2276 field
= c
->backend_decl
;
2277 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2280 /* Components can correspond to fields of different containing
2281 types, as components are created without context, whereas
2282 a concrete use of a component has the type of decl as context.
2283 So, if the type doesn't match, we search the corresponding
2284 FIELD_DECL in the parent type. To not waste too much time
2285 we cache this result in norestrict_decl. */
2287 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2289 tree f2
= c
->norestrict_decl
;
2290 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2291 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2292 if (TREE_CODE (f2
) == FIELD_DECL
2293 && DECL_NAME (f2
) == DECL_NAME (field
))
2296 c
->norestrict_decl
= f2
;
2300 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2301 && strcmp ("_data", c
->name
) == 0)
2303 /* Found a ref to the _data component. Store the associated ref to
2304 the vptr in se->class_vptr. */
2305 se
->class_vptr
= gfc_class_vptr_get (decl
);
2308 se
->class_vptr
= NULL_TREE
;
2310 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2311 decl
, field
, NULL_TREE
);
2315 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2316 strlen () conditional below. */
2317 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2318 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2320 tmp
= c
->ts
.u
.cl
->backend_decl
;
2321 /* Components must always be constant length. */
2322 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2323 se
->string_length
= tmp
;
2326 if (gfc_deferred_strlen (c
, &field
))
2328 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2330 decl
, field
, NULL_TREE
);
2331 se
->string_length
= tmp
;
2334 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2335 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2336 && c
->ts
.type
!= BT_CHARACTER
)
2337 || c
->attr
.proc_pointer
)
2338 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2343 /* This function deals with component references to components of the
2344 parent type for derived type extensions. */
2346 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2354 c
= ref
->u
.c
.component
;
2356 /* Return if the component is in the parent type. */
2357 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2358 if (strcmp (c
->name
, cmp
->name
) == 0)
2361 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2362 parent
.type
= REF_COMPONENT
;
2364 parent
.u
.c
.sym
= dt
;
2365 parent
.u
.c
.component
= dt
->components
;
2367 if (dt
->backend_decl
== NULL
)
2368 gfc_get_derived_type (dt
);
2370 /* Build the reference and call self. */
2371 gfc_conv_component_ref (se
, &parent
);
2372 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2373 parent
.u
.c
.component
= c
;
2374 conv_parent_component_references (se
, &parent
);
2377 /* Return the contents of a variable. Also handles reference/pointer
2378 variables (all Fortran pointer references are implicit). */
2381 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2386 tree parent_decl
= NULL_TREE
;
2389 bool alternate_entry
;
2392 bool first_time
= true;
2394 sym
= expr
->symtree
->n
.sym
;
2395 is_classarray
= IS_CLASS_ARRAY (sym
);
2399 gfc_ss_info
*ss_info
= ss
->info
;
2401 /* Check that something hasn't gone horribly wrong. */
2402 gcc_assert (ss
!= gfc_ss_terminator
);
2403 gcc_assert (ss_info
->expr
== expr
);
2405 /* A scalarized term. We already know the descriptor. */
2406 se
->expr
= ss_info
->data
.array
.descriptor
;
2407 se
->string_length
= ss_info
->string_length
;
2408 ref
= ss_info
->data
.array
.ref
;
2410 gcc_assert (ref
->type
== REF_ARRAY
2411 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2413 gfc_conv_tmp_array_ref (se
);
2417 tree se_expr
= NULL_TREE
;
2419 se
->expr
= gfc_get_symbol_decl (sym
);
2421 /* Deal with references to a parent results or entries by storing
2422 the current_function_decl and moving to the parent_decl. */
2423 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2424 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2425 && sym
->result
== sym
;
2426 entry_master
= sym
->attr
.result
2427 && sym
->ns
->proc_name
->attr
.entry_master
2428 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2429 if (current_function_decl
)
2430 parent_decl
= DECL_CONTEXT (current_function_decl
);
2432 if ((se
->expr
== parent_decl
&& return_value
)
2433 || (sym
->ns
&& sym
->ns
->proc_name
2435 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2436 && (alternate_entry
|| entry_master
)))
2441 /* Special case for assigning the return value of a function.
2442 Self recursive functions must have an explicit return value. */
2443 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2444 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2446 /* Similarly for alternate entry points. */
2447 else if (alternate_entry
2448 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2451 gfc_entry_list
*el
= NULL
;
2453 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2456 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2461 else if (entry_master
2462 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2464 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2469 /* Procedure actual arguments. */
2470 else if (sym
->attr
.flavor
== FL_PROCEDURE
2471 && se
->expr
!= current_function_decl
)
2473 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2475 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2476 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2482 /* Dereference the expression, where needed. Since characters
2483 are entirely different from other types, they are treated
2485 if (sym
->ts
.type
== BT_CHARACTER
)
2487 /* Dereference character pointer dummy arguments
2489 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2491 || sym
->attr
.function
2492 || sym
->attr
.result
))
2493 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2497 else if (!sym
->attr
.value
)
2499 /* Dereference temporaries for class array dummy arguments. */
2500 if (sym
->attr
.dummy
&& is_classarray
2501 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2503 if (!se
->descriptor_only
)
2504 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2506 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2510 /* Dereference non-character scalar dummy arguments. */
2511 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2512 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2513 && (sym
->ts
.type
!= BT_CLASS
2514 || (!CLASS_DATA (sym
)->attr
.dimension
2515 && !(CLASS_DATA (sym
)->attr
.codimension
2516 && CLASS_DATA (sym
)->attr
.allocatable
))))
2517 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2520 /* Dereference scalar hidden result. */
2521 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2522 && (sym
->attr
.function
|| sym
->attr
.result
)
2523 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2524 && !sym
->attr
.always_explicit
)
2525 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2528 /* Dereference non-character, non-class pointer variables.
2529 These must be dummies, results, or scalars. */
2531 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2532 || gfc_is_associate_pointer (sym
)
2533 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2535 || sym
->attr
.function
2537 || (!sym
->attr
.dimension
2538 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2539 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2541 /* Now treat the class array pointer variables accordingly. */
2542 else if (sym
->ts
.type
== BT_CLASS
2544 && (CLASS_DATA (sym
)->attr
.dimension
2545 || CLASS_DATA (sym
)->attr
.codimension
)
2546 && ((CLASS_DATA (sym
)->as
2547 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2548 || CLASS_DATA (sym
)->attr
.allocatable
2549 || CLASS_DATA (sym
)->attr
.class_pointer
))
2550 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2552 /* And the case where a non-dummy, non-result, non-function,
2553 non-allotable and non-pointer classarray is present. This case was
2554 previously covered by the first if, but with introducing the
2555 condition !is_classarray there, that case has to be covered
2557 else if (sym
->ts
.type
== BT_CLASS
2559 && !sym
->attr
.function
2560 && !sym
->attr
.result
2561 && (CLASS_DATA (sym
)->attr
.dimension
2562 || CLASS_DATA (sym
)->attr
.codimension
)
2564 || !CLASS_DATA (sym
)->attr
.allocatable
)
2565 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2566 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2573 /* For character variables, also get the length. */
2574 if (sym
->ts
.type
== BT_CHARACTER
)
2576 /* If the character length of an entry isn't set, get the length from
2577 the master function instead. */
2578 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2579 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2581 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2582 gcc_assert (se
->string_length
);
2590 /* Return the descriptor if that's what we want and this is an array
2591 section reference. */
2592 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2594 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2595 /* Return the descriptor for array pointers and allocations. */
2596 if (se
->want_pointer
2597 && ref
->next
== NULL
&& (se
->descriptor_only
))
2600 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2601 /* Return a pointer to an element. */
2605 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2606 && se
->descriptor_only
2607 && !CLASS_DATA (sym
)->attr
.allocatable
2608 && !CLASS_DATA (sym
)->attr
.class_pointer
2609 && CLASS_DATA (sym
)->as
2610 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2611 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2612 /* Skip the first ref of a _data component, because for class
2613 arrays that one is already done by introducing a temporary
2614 array descriptor. */
2617 if (ref
->u
.c
.sym
->attr
.extension
)
2618 conv_parent_component_references (se
, ref
);
2620 gfc_conv_component_ref (se
, ref
);
2621 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2622 && se
->want_pointer
&& se
->descriptor_only
)
2628 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2629 expr
->symtree
->name
, &expr
->where
);
2639 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2641 if (se
->want_pointer
)
2643 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2644 gfc_conv_string_parameter (se
);
2646 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2651 /* Unary ops are easy... Or they would be if ! was a valid op. */
2654 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2659 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2660 /* Initialize the operand. */
2661 gfc_init_se (&operand
, se
);
2662 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2663 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2665 type
= gfc_typenode_for_spec (&expr
->ts
);
2667 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2668 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2669 All other unary operators have an equivalent GIMPLE unary operator. */
2670 if (code
== TRUTH_NOT_EXPR
)
2671 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2672 build_int_cst (type
, 0));
2674 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2678 /* Expand power operator to optimal multiplications when a value is raised
2679 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2680 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2681 Programming", 3rd Edition, 1998. */
2683 /* This code is mostly duplicated from expand_powi in the backend.
2684 We establish the "optimal power tree" lookup table with the defined size.
2685 The items in the table are the exponents used to calculate the index
2686 exponents. Any integer n less than the value can get an "addition chain",
2687 with the first node being one. */
2688 #define POWI_TABLE_SIZE 256
2690 /* The table is from builtins.c. */
2691 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2693 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2694 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2695 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2696 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2697 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2698 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2699 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2700 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2701 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2702 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2703 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2704 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2705 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2706 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2707 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2708 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2709 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2710 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2711 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2712 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2713 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2714 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2715 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2716 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2717 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2718 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2719 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2720 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2721 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2722 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2723 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2724 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2727 /* If n is larger than lookup table's max index, we use the "window
2729 #define POWI_WINDOW_SIZE 3
2731 /* Recursive function to expand the power operator. The temporary
2732 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2734 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2741 if (n
< POWI_TABLE_SIZE
)
2746 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2747 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2751 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2752 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2753 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2757 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2761 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2762 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2764 if (n
< POWI_TABLE_SIZE
)
2771 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2772 return 1. Else return 0 and a call to runtime library functions
2773 will have to be built. */
2775 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2780 tree vartmp
[POWI_TABLE_SIZE
];
2782 unsigned HOST_WIDE_INT n
;
2784 wide_int wrhs
= rhs
;
2786 /* If exponent is too large, we won't expand it anyway, so don't bother
2787 with large integer values. */
2788 if (!wi::fits_shwi_p (wrhs
))
2791 m
= wrhs
.to_shwi ();
2792 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2793 of the asymmetric range of the integer type. */
2794 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2796 type
= TREE_TYPE (lhs
);
2797 sgn
= tree_int_cst_sgn (rhs
);
2799 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2800 || optimize_size
) && (m
> 2 || m
< -1))
2806 se
->expr
= gfc_build_const (type
, integer_one_node
);
2810 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2811 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2813 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2814 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2815 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2816 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2819 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2822 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2823 boolean_type_node
, tmp
, cond
);
2824 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2825 tmp
, build_int_cst (type
, 1),
2826 build_int_cst (type
, 0));
2830 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2831 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2832 build_int_cst (type
, -1),
2833 build_int_cst (type
, 0));
2834 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2835 cond
, build_int_cst (type
, 1), tmp
);
2839 memset (vartmp
, 0, sizeof (vartmp
));
2843 tmp
= gfc_build_const (type
, integer_one_node
);
2844 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2848 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2854 /* Power op (**). Constant integer exponent has special handling. */
2857 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2859 tree gfc_int4_type_node
;
2862 int res_ikind_1
, res_ikind_2
;
2867 gfc_init_se (&lse
, se
);
2868 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2869 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2870 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2872 gfc_init_se (&rse
, se
);
2873 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2874 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2876 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2877 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2878 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2881 gfc_int4_type_node
= gfc_get_int_type (4);
2883 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2884 library routine. But in the end, we have to convert the result back
2885 if this case applies -- with res_ikind_K, we keep track whether operand K
2886 falls into this case. */
2890 kind
= expr
->value
.op
.op1
->ts
.kind
;
2891 switch (expr
->value
.op
.op2
->ts
.type
)
2894 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2899 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2900 res_ikind_2
= ikind
;
2922 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2924 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2951 switch (expr
->value
.op
.op1
->ts
.type
)
2954 if (kind
== 3) /* Case 16 was not handled properly above. */
2956 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2960 /* Use builtins for real ** int4. */
2966 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2970 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2974 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2978 /* Use the __builtin_powil() only if real(kind=16) is
2979 actually the C long double type. */
2980 if (!gfc_real16_is_float128
)
2981 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2989 /* If we don't have a good builtin for this, go for the
2990 library function. */
2992 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2996 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3005 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3009 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3017 se
->expr
= build_call_expr_loc (input_location
,
3018 fndecl
, 2, lse
.expr
, rse
.expr
);
3020 /* Convert the result back if it is of wrong integer kind. */
3021 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3023 /* We want the maximum of both operand kinds as result. */
3024 if (res_ikind_1
< res_ikind_2
)
3025 res_ikind_1
= res_ikind_2
;
3026 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3031 /* Generate code to allocate a string temporary. */
3034 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3039 if (gfc_can_put_var_on_stack (len
))
3041 /* Create a temporary variable to hold the result. */
3042 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3043 gfc_charlen_type_node
, len
,
3044 build_int_cst (gfc_charlen_type_node
, 1));
3045 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3047 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3048 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3050 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3052 var
= gfc_create_var (tmp
, "str");
3053 var
= gfc_build_addr_expr (type
, var
);
3057 /* Allocate a temporary to hold the result. */
3058 var
= gfc_create_var (type
, "pstr");
3059 gcc_assert (POINTER_TYPE_P (type
));
3060 tmp
= TREE_TYPE (type
);
3061 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3062 tmp
= TREE_TYPE (tmp
);
3063 tmp
= TYPE_SIZE_UNIT (tmp
);
3064 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3065 fold_convert (size_type_node
, len
),
3066 fold_convert (size_type_node
, tmp
));
3067 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3068 gfc_add_modify (&se
->pre
, var
, tmp
);
3070 /* Free the temporary afterwards. */
3071 tmp
= gfc_call_free (var
);
3072 gfc_add_expr_to_block (&se
->post
, tmp
);
3079 /* Handle a string concatenation operation. A temporary will be allocated to
3083 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3086 tree len
, type
, var
, tmp
, fndecl
;
3088 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3089 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3090 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3092 gfc_init_se (&lse
, se
);
3093 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3094 gfc_conv_string_parameter (&lse
);
3095 gfc_init_se (&rse
, se
);
3096 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3097 gfc_conv_string_parameter (&rse
);
3099 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3100 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3102 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3103 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3104 if (len
== NULL_TREE
)
3106 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3107 TREE_TYPE (lse
.string_length
),
3108 lse
.string_length
, rse
.string_length
);
3111 type
= build_pointer_type (type
);
3113 var
= gfc_conv_string_tmp (se
, type
, len
);
3115 /* Do the actual concatenation. */
3116 if (expr
->ts
.kind
== 1)
3117 fndecl
= gfor_fndecl_concat_string
;
3118 else if (expr
->ts
.kind
== 4)
3119 fndecl
= gfor_fndecl_concat_string_char4
;
3123 tmp
= build_call_expr_loc (input_location
,
3124 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3125 rse
.string_length
, rse
.expr
);
3126 gfc_add_expr_to_block (&se
->pre
, tmp
);
3128 /* Add the cleanup for the operands. */
3129 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3130 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3133 se
->string_length
= len
;
3136 /* Translates an op expression. Common (binary) cases are handled by this
3137 function, others are passed on. Recursion is used in either case.
3138 We use the fact that (op1.ts == op2.ts) (except for the power
3140 Operators need no special handling for scalarized expressions as long as
3141 they call gfc_conv_simple_val to get their operands.
3142 Character strings get special handling. */
3145 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3147 enum tree_code code
;
3156 switch (expr
->value
.op
.op
)
3158 case INTRINSIC_PARENTHESES
:
3159 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3160 && flag_protect_parens
)
3162 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3163 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3168 case INTRINSIC_UPLUS
:
3169 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3172 case INTRINSIC_UMINUS
:
3173 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3177 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3180 case INTRINSIC_PLUS
:
3184 case INTRINSIC_MINUS
:
3188 case INTRINSIC_TIMES
:
3192 case INTRINSIC_DIVIDE
:
3193 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3194 an integer, we must round towards zero, so we use a
3196 if (expr
->ts
.type
== BT_INTEGER
)
3197 code
= TRUNC_DIV_EXPR
;
3202 case INTRINSIC_POWER
:
3203 gfc_conv_power_op (se
, expr
);
3206 case INTRINSIC_CONCAT
:
3207 gfc_conv_concat_op (se
, expr
);
3211 code
= TRUTH_ANDIF_EXPR
;
3216 code
= TRUTH_ORIF_EXPR
;
3220 /* EQV and NEQV only work on logicals, but since we represent them
3221 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3223 case INTRINSIC_EQ_OS
:
3231 case INTRINSIC_NE_OS
:
3232 case INTRINSIC_NEQV
:
3239 case INTRINSIC_GT_OS
:
3246 case INTRINSIC_GE_OS
:
3253 case INTRINSIC_LT_OS
:
3260 case INTRINSIC_LE_OS
:
3266 case INTRINSIC_USER
:
3267 case INTRINSIC_ASSIGN
:
3268 /* These should be converted into function calls by the frontend. */
3272 fatal_error (input_location
, "Unknown intrinsic op");
3276 /* The only exception to this is **, which is handled separately anyway. */
3277 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3279 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3283 gfc_init_se (&lse
, se
);
3284 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3285 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3288 gfc_init_se (&rse
, se
);
3289 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3290 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3294 gfc_conv_string_parameter (&lse
);
3295 gfc_conv_string_parameter (&rse
);
3297 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3298 rse
.string_length
, rse
.expr
,
3299 expr
->value
.op
.op1
->ts
.kind
,
3301 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3302 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3305 type
= gfc_typenode_for_spec (&expr
->ts
);
3309 /* The result of logical ops is always boolean_type_node. */
3310 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3311 lse
.expr
, rse
.expr
);
3312 se
->expr
= convert (type
, tmp
);
3315 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3317 /* Add the post blocks. */
3318 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3319 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3322 /* If a string's length is one, we convert it to a single character. */
3325 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3329 || !tree_fits_uhwi_p (len
)
3330 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3333 if (TREE_INT_CST_LOW (len
) == 1)
3335 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3336 return build_fold_indirect_ref_loc (input_location
, str
);
3340 && TREE_CODE (str
) == ADDR_EXPR
3341 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3342 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3343 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3344 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3345 && TREE_INT_CST_LOW (len
) > 1
3346 && TREE_INT_CST_LOW (len
)
3347 == (unsigned HOST_WIDE_INT
)
3348 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3350 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3351 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3352 if (TREE_CODE (ret
) == INTEGER_CST
)
3354 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3355 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3356 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3358 for (i
= 1; i
< length
; i
++)
3371 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3374 if (sym
->backend_decl
)
3376 /* This becomes the nominal_type in
3377 function.c:assign_parm_find_data_types. */
3378 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3379 /* This becomes the passed_type in
3380 function.c:assign_parm_find_data_types. C promotes char to
3381 integer for argument passing. */
3382 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3384 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3389 /* If we have a constant character expression, make it into an
3391 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3396 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3397 (int)(*expr
)->value
.character
.string
[0]);
3398 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3400 /* The expr needs to be compatible with a C int. If the
3401 conversion fails, then the 2 causes an ICE. */
3402 ts
.type
= BT_INTEGER
;
3403 ts
.kind
= gfc_c_int_kind
;
3404 gfc_convert_type (*expr
, &ts
, 2);
3407 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3409 if ((*expr
)->ref
== NULL
)
3411 se
->expr
= gfc_string_to_single_character
3412 (build_int_cst (integer_type_node
, 1),
3413 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3415 ((*expr
)->symtree
->n
.sym
)),
3420 gfc_conv_variable (se
, *expr
);
3421 se
->expr
= gfc_string_to_single_character
3422 (build_int_cst (integer_type_node
, 1),
3423 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3431 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3432 if STR is a string literal, otherwise return -1. */
3435 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3438 && TREE_CODE (str
) == ADDR_EXPR
3439 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3440 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3441 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3442 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3443 && tree_fits_uhwi_p (len
)
3444 && tree_to_uhwi (len
) >= 1
3445 && tree_to_uhwi (len
)
3446 == (unsigned HOST_WIDE_INT
)
3447 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3449 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3450 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3451 if (TREE_CODE (folded
) == INTEGER_CST
)
3453 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3454 int length
= TREE_STRING_LENGTH (string_cst
);
3455 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3457 for (; length
> 0; length
--)
3458 if (ptr
[length
- 1] != ' ')
3467 /* Helper to build a call to memcmp. */
3470 build_memcmp_call (tree s1
, tree s2
, tree n
)
3474 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3475 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3477 s1
= fold_convert (pvoid_type_node
, s1
);
3479 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3480 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3482 s2
= fold_convert (pvoid_type_node
, s2
);
3484 n
= fold_convert (size_type_node
, n
);
3486 tmp
= build_call_expr_loc (input_location
,
3487 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3490 return fold_convert (integer_type_node
, tmp
);
3493 /* Compare two strings. If they are all single characters, the result is the
3494 subtraction of them. Otherwise, we build a library call. */
3497 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3498 enum tree_code code
)
3504 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3505 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3507 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3508 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3510 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3512 /* Deal with single character specially. */
3513 sc1
= fold_convert (integer_type_node
, sc1
);
3514 sc2
= fold_convert (integer_type_node
, sc2
);
3515 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3519 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3521 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3523 /* If one string is a string literal with LEN_TRIM longer
3524 than the length of the second string, the strings
3526 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3527 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3528 return integer_one_node
;
3529 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3530 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3531 return integer_one_node
;
3534 /* We can compare via memcpy if the strings are known to be equal
3535 in length and they are
3537 - kind=4 and the comparison is for (in)equality. */
3539 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3540 && tree_int_cst_equal (len1
, len2
)
3541 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3546 chartype
= gfc_get_char_type (kind
);
3547 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3548 fold_convert (TREE_TYPE(len1
),
3549 TYPE_SIZE_UNIT(chartype
)),
3551 return build_memcmp_call (str1
, str2
, tmp
);
3554 /* Build a call for the comparison. */
3556 fndecl
= gfor_fndecl_compare_string
;
3558 fndecl
= gfor_fndecl_compare_string_char4
;
3562 return build_call_expr_loc (input_location
, fndecl
, 4,
3563 len1
, str1
, len2
, str2
);
3567 /* Return the backend_decl for a procedure pointer component. */
3570 get_proc_ptr_comp (gfc_expr
*e
)
3576 gfc_init_se (&comp_se
, NULL
);
3577 e2
= gfc_copy_expr (e
);
3578 /* We have to restore the expr type later so that gfc_free_expr frees
3579 the exact same thing that was allocated.
3580 TODO: This is ugly. */
3581 old_type
= e2
->expr_type
;
3582 e2
->expr_type
= EXPR_VARIABLE
;
3583 gfc_conv_expr (&comp_se
, e2
);
3584 e2
->expr_type
= old_type
;
3586 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3590 /* Convert a typebound function reference from a class object. */
3592 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3597 if (TREE_CODE (base_object
) != VAR_DECL
)
3599 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3600 gfc_add_modify (&se
->pre
, var
, base_object
);
3602 se
->expr
= gfc_class_vptr_get (base_object
);
3603 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3605 while (ref
&& ref
->next
)
3607 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3608 if (ref
->u
.c
.sym
->attr
.extension
)
3609 conv_parent_component_references (se
, ref
);
3610 gfc_conv_component_ref (se
, ref
);
3611 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3616 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3620 if (gfc_is_proc_ptr_comp (expr
))
3621 tmp
= get_proc_ptr_comp (expr
);
3622 else if (sym
->attr
.dummy
)
3624 tmp
= gfc_get_symbol_decl (sym
);
3625 if (sym
->attr
.proc_pointer
)
3626 tmp
= build_fold_indirect_ref_loc (input_location
,
3628 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3629 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3633 if (!sym
->backend_decl
)
3634 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3636 TREE_USED (sym
->backend_decl
) = 1;
3638 tmp
= sym
->backend_decl
;
3640 if (sym
->attr
.cray_pointee
)
3642 /* TODO - make the cray pointee a pointer to a procedure,
3643 assign the pointer to it and use it for the call. This
3645 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3646 gfc_get_symbol_decl (sym
->cp_pointer
));
3647 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3650 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3652 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3653 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3660 /* Initialize MAPPING. */
3663 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3665 mapping
->syms
= NULL
;
3666 mapping
->charlens
= NULL
;
3670 /* Free all memory held by MAPPING (but not MAPPING itself). */
3673 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3675 gfc_interface_sym_mapping
*sym
;
3676 gfc_interface_sym_mapping
*nextsym
;
3678 gfc_charlen
*nextcl
;
3680 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3682 nextsym
= sym
->next
;
3683 sym
->new_sym
->n
.sym
->formal
= NULL
;
3684 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3685 gfc_free_expr (sym
->expr
);
3686 free (sym
->new_sym
);
3689 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3692 gfc_free_expr (cl
->length
);
3698 /* Return a copy of gfc_charlen CL. Add the returned structure to
3699 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3701 static gfc_charlen
*
3702 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3705 gfc_charlen
*new_charlen
;
3707 new_charlen
= gfc_get_charlen ();
3708 new_charlen
->next
= mapping
->charlens
;
3709 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3711 mapping
->charlens
= new_charlen
;
3716 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3717 array variable that can be used as the actual argument for dummy
3718 argument SYM. Add any initialization code to BLOCK. PACKED is as
3719 for gfc_get_nodesc_array_type and DATA points to the first element
3720 in the passed array. */
3723 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3724 gfc_packed packed
, tree data
)
3729 type
= gfc_typenode_for_spec (&sym
->ts
);
3730 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3731 !sym
->attr
.target
&& !sym
->attr
.pointer
3732 && !sym
->attr
.proc_pointer
);
3734 var
= gfc_create_var (type
, "ifm");
3735 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3741 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3742 and offset of descriptorless array type TYPE given that it has the same
3743 size as DESC. Add any set-up code to BLOCK. */
3746 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3753 offset
= gfc_index_zero_node
;
3754 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3756 dim
= gfc_rank_cst
[n
];
3757 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3758 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3760 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3761 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3762 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3763 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3765 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3767 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3768 gfc_array_index_type
,
3769 gfc_conv_descriptor_ubound_get (desc
, dim
),
3770 gfc_conv_descriptor_lbound_get (desc
, dim
));
3771 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3772 gfc_array_index_type
,
3773 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3774 tmp
= gfc_evaluate_now (tmp
, block
);
3775 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3777 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3778 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3779 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3780 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3781 gfc_array_index_type
, offset
, tmp
);
3783 offset
= gfc_evaluate_now (offset
, block
);
3784 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3788 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3789 in SE. The caller may still use se->expr and se->string_length after
3790 calling this function. */
3793 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3794 gfc_symbol
* sym
, gfc_se
* se
,
3797 gfc_interface_sym_mapping
*sm
;
3801 gfc_symbol
*new_sym
;
3803 gfc_symtree
*new_symtree
;
3805 /* Create a new symbol to represent the actual argument. */
3806 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3807 new_sym
->ts
= sym
->ts
;
3808 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3809 new_sym
->attr
.referenced
= 1;
3810 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3811 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3812 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3813 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3814 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3815 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3816 new_sym
->attr
.function
= sym
->attr
.function
;
3818 /* Ensure that the interface is available and that
3819 descriptors are passed for array actual arguments. */
3820 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3822 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3823 new_sym
->attr
.always_explicit
3824 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3827 /* Create a fake symtree for it. */
3829 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3830 new_symtree
->n
.sym
= new_sym
;
3831 gcc_assert (new_symtree
== root
);
3833 /* Create a dummy->actual mapping. */
3834 sm
= XCNEW (gfc_interface_sym_mapping
);
3835 sm
->next
= mapping
->syms
;
3837 sm
->new_sym
= new_symtree
;
3838 sm
->expr
= gfc_copy_expr (expr
);
3841 /* Stabilize the argument's value. */
3842 if (!sym
->attr
.function
&& se
)
3843 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3845 if (sym
->ts
.type
== BT_CHARACTER
)
3847 /* Create a copy of the dummy argument's length. */
3848 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3849 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3851 /* If the length is specified as "*", record the length that
3852 the caller is passing. We should use the callee's length
3853 in all other cases. */
3854 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3856 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3857 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3864 /* Use the passed value as-is if the argument is a function. */
3865 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3868 /* If the argument is either a string or a pointer to a string,
3869 convert it to a boundless character type. */
3870 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3872 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3873 tmp
= build_pointer_type (tmp
);
3874 if (sym
->attr
.pointer
)
3875 value
= build_fold_indirect_ref_loc (input_location
,
3879 value
= fold_convert (tmp
, value
);
3882 /* If the argument is a scalar, a pointer to an array or an allocatable,
3884 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3885 value
= build_fold_indirect_ref_loc (input_location
,
3888 /* For character(*), use the actual argument's descriptor. */
3889 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3890 value
= build_fold_indirect_ref_loc (input_location
,
3893 /* If the argument is an array descriptor, use it to determine
3894 information about the actual argument's shape. */
3895 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3896 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3898 /* Get the actual argument's descriptor. */
3899 desc
= build_fold_indirect_ref_loc (input_location
,
3902 /* Create the replacement variable. */
3903 tmp
= gfc_conv_descriptor_data_get (desc
);
3904 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3907 /* Use DESC to work out the upper bounds, strides and offset. */
3908 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3911 /* Otherwise we have a packed array. */
3912 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3913 PACKED_FULL
, se
->expr
);
3915 new_sym
->backend_decl
= value
;
3919 /* Called once all dummy argument mappings have been added to MAPPING,
3920 but before the mapping is used to evaluate expressions. Pre-evaluate
3921 the length of each argument, adding any initialization code to PRE and
3922 any finalization code to POST. */
3925 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3926 stmtblock_t
* pre
, stmtblock_t
* post
)
3928 gfc_interface_sym_mapping
*sym
;
3932 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3933 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3934 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3936 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3937 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3938 gfc_init_se (&se
, NULL
);
3939 gfc_conv_expr (&se
, expr
);
3940 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3941 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3942 gfc_add_block_to_block (pre
, &se
.pre
);
3943 gfc_add_block_to_block (post
, &se
.post
);
3945 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3950 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3954 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3955 gfc_constructor_base base
)
3958 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3960 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3963 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3964 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3965 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3971 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3975 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3980 for (; ref
; ref
= ref
->next
)
3984 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3986 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3987 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3988 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3996 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3997 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4003 /* Convert intrinsic function calls into result expressions. */
4006 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4014 arg1
= expr
->value
.function
.actual
->expr
;
4015 if (expr
->value
.function
.actual
->next
)
4016 arg2
= expr
->value
.function
.actual
->next
->expr
;
4020 sym
= arg1
->symtree
->n
.sym
;
4022 if (sym
->attr
.dummy
)
4027 switch (expr
->value
.function
.isym
->id
)
4030 /* TODO figure out why this condition is necessary. */
4031 if (sym
->attr
.function
4032 && (arg1
->ts
.u
.cl
->length
== NULL
4033 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4034 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4037 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4041 if (!sym
->as
|| sym
->as
->rank
== 0)
4044 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4046 dup
= mpz_get_si (arg2
->value
.integer
);
4051 dup
= sym
->as
->rank
;
4055 for (; d
< dup
; d
++)
4059 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4061 gfc_free_expr (new_expr
);
4065 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4066 gfc_get_int_expr (gfc_default_integer_kind
,
4068 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4070 new_expr
= gfc_multiply (new_expr
, tmp
);
4076 case GFC_ISYM_LBOUND
:
4077 case GFC_ISYM_UBOUND
:
4078 /* TODO These implementations of lbound and ubound do not limit if
4079 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4081 if (!sym
->as
|| sym
->as
->rank
== 0)
4084 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4085 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4087 /* TODO: If the need arises, this could produce an array of
4091 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4093 if (sym
->as
->lower
[d
])
4094 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4098 if (sym
->as
->upper
[d
])
4099 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4107 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4111 gfc_replace_expr (expr
, new_expr
);
4117 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4118 gfc_interface_mapping
* mapping
)
4120 gfc_formal_arglist
*f
;
4121 gfc_actual_arglist
*actual
;
4123 actual
= expr
->value
.function
.actual
;
4124 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4126 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4131 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4134 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4139 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4141 for (d
= 0; d
< as
->rank
; d
++)
4143 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4144 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4147 expr
->value
.function
.esym
->as
= as
;
4150 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4152 expr
->value
.function
.esym
->ts
.u
.cl
->length
4153 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4155 gfc_apply_interface_mapping_to_expr (mapping
,
4156 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4161 /* EXPR is a copy of an expression that appeared in the interface
4162 associated with MAPPING. Walk it recursively looking for references to
4163 dummy arguments that MAPPING maps to actual arguments. Replace each such
4164 reference with a reference to the associated actual argument. */
4167 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4170 gfc_interface_sym_mapping
*sym
;
4171 gfc_actual_arglist
*actual
;
4176 /* Copying an expression does not copy its length, so do that here. */
4177 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4179 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4180 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4183 /* Apply the mapping to any references. */
4184 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4186 /* ...and to the expression's symbol, if it has one. */
4187 /* TODO Find out why the condition on expr->symtree had to be moved into
4188 the loop rather than being outside it, as originally. */
4189 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4190 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4192 if (sym
->new_sym
->n
.sym
->backend_decl
)
4193 expr
->symtree
= sym
->new_sym
;
4195 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4198 /* ...and to subexpressions in expr->value. */
4199 switch (expr
->expr_type
)
4204 case EXPR_SUBSTRING
:
4208 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4209 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4213 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4214 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4216 if (expr
->value
.function
.esym
== NULL
4217 && expr
->value
.function
.isym
!= NULL
4218 && expr
->value
.function
.actual
->expr
->symtree
4219 && gfc_map_intrinsic_function (expr
, mapping
))
4222 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4223 if (sym
->old
== expr
->value
.function
.esym
)
4225 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4226 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4227 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4232 case EXPR_STRUCTURE
:
4233 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4246 /* Evaluate interface expression EXPR using MAPPING. Store the result
4250 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4251 gfc_se
* se
, gfc_expr
* expr
)
4253 expr
= gfc_copy_expr (expr
);
4254 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4255 gfc_conv_expr (se
, expr
);
4256 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4257 gfc_free_expr (expr
);
4261 /* Returns a reference to a temporary array into which a component of
4262 an actual argument derived type array is copied and then returned
4263 after the function call. */
4265 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4266 sym_intent intent
, bool formal_ptr
)
4274 gfc_array_info
*info
;
4284 gfc_init_se (&lse
, NULL
);
4285 gfc_init_se (&rse
, NULL
);
4287 /* Walk the argument expression. */
4288 rss
= gfc_walk_expr (expr
);
4290 gcc_assert (rss
!= gfc_ss_terminator
);
4292 /* Initialize the scalarizer. */
4293 gfc_init_loopinfo (&loop
);
4294 gfc_add_ss_to_loop (&loop
, rss
);
4296 /* Calculate the bounds of the scalarization. */
4297 gfc_conv_ss_startstride (&loop
);
4299 /* Build an ss for the temporary. */
4300 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4301 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4303 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4304 if (GFC_ARRAY_TYPE_P (base_type
)
4305 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4306 base_type
= gfc_get_element_type (base_type
);
4308 if (expr
->ts
.type
== BT_CLASS
)
4309 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4311 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4312 ? expr
->ts
.u
.cl
->backend_decl
4316 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4318 /* Associate the SS with the loop. */
4319 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4321 /* Setup the scalarizing loops. */
4322 gfc_conv_loop_setup (&loop
, &expr
->where
);
4324 /* Pass the temporary descriptor back to the caller. */
4325 info
= &loop
.temp_ss
->info
->data
.array
;
4326 parmse
->expr
= info
->descriptor
;
4328 /* Setup the gfc_se structures. */
4329 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4330 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4333 lse
.ss
= loop
.temp_ss
;
4334 gfc_mark_ss_chain_used (rss
, 1);
4335 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4337 /* Start the scalarized loop body. */
4338 gfc_start_scalarized_body (&loop
, &body
);
4340 /* Translate the expression. */
4341 gfc_conv_expr (&rse
, expr
);
4343 /* Reset the offset for the function call since the loop
4344 is zero based on the data pointer. Note that the temp
4345 comes first in the loop chain since it is added second. */
4346 if (gfc_is_alloc_class_array_function (expr
))
4348 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4349 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4350 gfc_index_zero_node
);
4353 gfc_conv_tmp_array_ref (&lse
);
4355 if (intent
!= INTENT_OUT
)
4357 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4358 gfc_add_expr_to_block (&body
, tmp
);
4359 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4360 gfc_trans_scalarizing_loops (&loop
, &body
);
4364 /* Make sure that the temporary declaration survives by merging
4365 all the loop declarations into the current context. */
4366 for (n
= 0; n
< loop
.dimen
; n
++)
4368 gfc_merge_block_scope (&body
);
4369 body
= loop
.code
[loop
.order
[n
]];
4371 gfc_merge_block_scope (&body
);
4374 /* Add the post block after the second loop, so that any
4375 freeing of allocated memory is done at the right time. */
4376 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4378 /**********Copy the temporary back again.*********/
4380 gfc_init_se (&lse
, NULL
);
4381 gfc_init_se (&rse
, NULL
);
4383 /* Walk the argument expression. */
4384 lss
= gfc_walk_expr (expr
);
4385 rse
.ss
= loop
.temp_ss
;
4388 /* Initialize the scalarizer. */
4389 gfc_init_loopinfo (&loop2
);
4390 gfc_add_ss_to_loop (&loop2
, lss
);
4392 dimen
= rse
.ss
->dimen
;
4394 /* Skip the write-out loop for this case. */
4395 if (gfc_is_alloc_class_array_function (expr
))
4396 goto class_array_fcn
;
4398 /* Calculate the bounds of the scalarization. */
4399 gfc_conv_ss_startstride (&loop2
);
4401 /* Setup the scalarizing loops. */
4402 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4404 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4405 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4407 gfc_mark_ss_chain_used (lss
, 1);
4408 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4410 /* Declare the variable to hold the temporary offset and start the
4411 scalarized loop body. */
4412 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4413 gfc_start_scalarized_body (&loop2
, &body
);
4415 /* Build the offsets for the temporary from the loop variables. The
4416 temporary array has lbounds of zero and strides of one in all
4417 dimensions, so this is very simple. The offset is only computed
4418 outside the innermost loop, so the overall transfer could be
4419 optimized further. */
4420 info
= &rse
.ss
->info
->data
.array
;
4422 tmp_index
= gfc_index_zero_node
;
4423 for (n
= dimen
- 1; n
> 0; n
--)
4426 tmp
= rse
.loop
->loopvar
[n
];
4427 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4428 tmp
, rse
.loop
->from
[n
]);
4429 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4432 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4433 gfc_array_index_type
,
4434 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4435 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4436 gfc_array_index_type
,
4437 tmp_str
, gfc_index_one_node
);
4439 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4440 gfc_array_index_type
, tmp
, tmp_str
);
4443 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4444 gfc_array_index_type
,
4445 tmp_index
, rse
.loop
->from
[0]);
4446 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4448 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4449 gfc_array_index_type
,
4450 rse
.loop
->loopvar
[0], offset
);
4452 /* Now use the offset for the reference. */
4453 tmp
= build_fold_indirect_ref_loc (input_location
,
4455 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4457 if (expr
->ts
.type
== BT_CHARACTER
)
4458 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4460 gfc_conv_expr (&lse
, expr
);
4462 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4464 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4465 gfc_add_expr_to_block (&body
, tmp
);
4467 /* Generate the copying loops. */
4468 gfc_trans_scalarizing_loops (&loop2
, &body
);
4470 /* Wrap the whole thing up by adding the second loop to the post-block
4471 and following it by the post-block of the first loop. In this way,
4472 if the temporary needs freeing, it is done after use! */
4473 if (intent
!= INTENT_IN
)
4475 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4476 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4481 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4483 gfc_cleanup_loop (&loop
);
4484 gfc_cleanup_loop (&loop2
);
4486 /* Pass the string length to the argument expression. */
4487 if (expr
->ts
.type
== BT_CHARACTER
)
4488 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4490 /* Determine the offset for pointer formal arguments and set the
4494 size
= gfc_index_one_node
;
4495 offset
= gfc_index_zero_node
;
4496 for (n
= 0; n
< dimen
; n
++)
4498 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4500 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4501 gfc_array_index_type
, tmp
,
4502 gfc_index_one_node
);
4503 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4507 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4510 gfc_index_one_node
);
4511 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4512 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4513 gfc_array_index_type
,
4515 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4516 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4517 gfc_array_index_type
,
4518 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4519 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4520 gfc_array_index_type
,
4521 tmp
, gfc_index_one_node
);
4522 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4523 gfc_array_index_type
, size
, tmp
);
4526 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4530 /* We want either the address for the data or the address of the descriptor,
4531 depending on the mode of passing array arguments. */
4533 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4535 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4541 /* Generate the code for argument list functions. */
4544 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4546 /* Pass by value for g77 %VAL(arg), pass the address
4547 indirectly for %LOC, else by reference. Thus %REF
4548 is a "do-nothing" and %LOC is the same as an F95
4550 if (strncmp (name
, "%VAL", 4) == 0)
4551 gfc_conv_expr (se
, expr
);
4552 else if (strncmp (name
, "%LOC", 4) == 0)
4554 gfc_conv_expr_reference (se
, expr
);
4555 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4557 else if (strncmp (name
, "%REF", 4) == 0)
4558 gfc_conv_expr_reference (se
, expr
);
4560 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4564 /* This function tells whether the middle-end representation of the expression
4565 E given as input may point to data otherwise accessible through a variable
4567 It is assumed that the only expressions that may alias are variables,
4568 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4570 This function is used to decide whether freeing an expression's allocatable
4571 components is safe or should be avoided.
4573 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4574 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4575 is necessary because for array constructors, aliasing depends on how
4577 - If E is an array constructor used as argument to an elemental procedure,
4578 the array, which is generated through shallow copy by the scalarizer,
4579 is used directly and can alias the expressions it was copied from.
4580 - If E is an array constructor used as argument to a non-elemental
4581 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4582 the array as in the previous case, but then that array is used
4583 to initialize a new descriptor through deep copy. There is no alias
4584 possible in that case.
4585 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4589 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4593 if (e
->expr_type
== EXPR_VARIABLE
)
4595 else if (e
->expr_type
== EXPR_FUNCTION
)
4597 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4599 if ((proc_ifc
->result
->ts
.type
== BT_CLASS
4600 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4601 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4602 || proc_ifc
->result
->attr
.pointer
)
4607 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4610 for (c
= gfc_constructor_first (e
->value
.constructor
);
4611 c
; c
= gfc_constructor_next (c
))
4613 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4620 /* Generate code for a procedure call. Note can return se->post != NULL.
4621 If se->direct_byref is set then se->expr contains the return parameter.
4622 Return nonzero, if the call has alternate specifiers.
4623 'expr' is only needed for procedure pointer components. */
4626 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4627 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4628 vec
<tree
, va_gc
> *append_args
)
4630 gfc_interface_mapping mapping
;
4631 vec
<tree
, va_gc
> *arglist
;
4632 vec
<tree
, va_gc
> *retargs
;
4636 gfc_array_info
*info
;
4643 vec
<tree
, va_gc
> *stringargs
;
4644 vec
<tree
, va_gc
> *optionalargs
;
4646 gfc_formal_arglist
*formal
;
4647 gfc_actual_arglist
*arg
;
4648 int has_alternate_specifier
= 0;
4649 bool need_interface_mapping
;
4657 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4658 gfc_component
*comp
= NULL
;
4665 optionalargs
= NULL
;
4670 comp
= gfc_get_proc_ptr_comp (expr
);
4672 bool elemental_proc
= (comp
4673 && comp
->ts
.interface
4674 && comp
->ts
.interface
->attr
.elemental
)
4675 || (comp
&& comp
->attr
.elemental
)
4676 || sym
->attr
.elemental
;
4680 if (!elemental_proc
)
4682 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4683 if (se
->ss
->info
->useflags
)
4685 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4686 && sym
->result
->attr
.dimension
)
4687 || (comp
&& comp
->attr
.dimension
)
4688 || gfc_is_alloc_class_array_function (expr
));
4689 gcc_assert (se
->loop
!= NULL
);
4690 /* Access the previously obtained result. */
4691 gfc_conv_tmp_array_ref (se
);
4695 info
= &se
->ss
->info
->data
.array
;
4700 gfc_init_block (&post
);
4701 gfc_init_interface_mapping (&mapping
);
4704 formal
= gfc_sym_get_dummy_args (sym
);
4705 need_interface_mapping
= sym
->attr
.dimension
||
4706 (sym
->ts
.type
== BT_CHARACTER
4707 && sym
->ts
.u
.cl
->length
4708 && sym
->ts
.u
.cl
->length
->expr_type
4713 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4714 need_interface_mapping
= comp
->attr
.dimension
||
4715 (comp
->ts
.type
== BT_CHARACTER
4716 && comp
->ts
.u
.cl
->length
4717 && comp
->ts
.u
.cl
->length
->expr_type
4721 base_object
= NULL_TREE
;
4722 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4723 is the third and fourth argument to such a function call a value
4724 denoting the number of elements to copy (i.e., most of the time the
4725 length of a deferred length string). */
4726 ulim_copy
= formal
== NULL
&& UNLIMITED_POLY (sym
)
4727 && strcmp ("_copy", comp
->name
) == 0;
4729 /* Evaluate the arguments. */
4730 for (arg
= args
, argc
= 0; arg
!= NULL
;
4731 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4734 fsym
= formal
? formal
->sym
: NULL
;
4735 parm_kind
= MISSING
;
4737 /* If the procedure requires an explicit interface, the actual
4738 argument is passed according to the corresponding formal
4739 argument. If the corresponding formal argument is a POINTER,
4740 ALLOCATABLE or assumed shape, we do not use g77's calling
4741 convention, and pass the address of the array descriptor
4742 instead. Otherwise we use g77's calling convention, in other words
4743 pass the array data pointer without descriptor. */
4744 bool nodesc_arg
= fsym
!= NULL
4745 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4747 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4748 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4750 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4752 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4754 /* Class array expressions are sometimes coming completely unadorned
4755 with either arrayspec or _data component. Correct that here.
4756 OOP-TODO: Move this to the frontend. */
4757 if (e
&& e
->expr_type
== EXPR_VARIABLE
4759 && e
->ts
.type
== BT_CLASS
4760 && (CLASS_DATA (e
)->attr
.codimension
4761 || CLASS_DATA (e
)->attr
.dimension
))
4763 gfc_typespec temp_ts
= e
->ts
;
4764 gfc_add_class_array_ref (e
);
4770 if (se
->ignore_optional
)
4772 /* Some intrinsics have already been resolved to the correct
4776 else if (arg
->label
)
4778 has_alternate_specifier
= 1;
4783 gfc_init_se (&parmse
, NULL
);
4785 /* For scalar arguments with VALUE attribute which are passed by
4786 value, pass "0" and a hidden argument gives the optional
4788 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4789 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4790 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4792 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4794 vec_safe_push (optionalargs
, boolean_false_node
);
4798 /* Pass a NULL pointer for an absent arg. */
4799 parmse
.expr
= null_pointer_node
;
4800 if (arg
->missing_arg_type
== BT_CHARACTER
)
4801 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4806 else if (arg
->expr
->expr_type
== EXPR_NULL
4807 && fsym
&& !fsym
->attr
.pointer
4808 && (fsym
->ts
.type
!= BT_CLASS
4809 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4811 /* Pass a NULL pointer to denote an absent arg. */
4812 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4813 && (fsym
->ts
.type
!= BT_CLASS
4814 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4815 gfc_init_se (&parmse
, NULL
);
4816 parmse
.expr
= null_pointer_node
;
4817 if (arg
->missing_arg_type
== BT_CHARACTER
)
4818 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4820 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4821 && e
->ts
.type
== BT_DERIVED
)
4823 /* The derived type needs to be converted to a temporary
4825 gfc_init_se (&parmse
, se
);
4826 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4828 && e
->expr_type
== EXPR_VARIABLE
4829 && e
->symtree
->n
.sym
->attr
.optional
,
4830 CLASS_DATA (fsym
)->attr
.class_pointer
4831 || CLASS_DATA (fsym
)->attr
.allocatable
);
4833 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4835 /* The intrinsic type needs to be converted to a temporary
4836 CLASS object for the unlimited polymorphic formal. */
4837 gfc_init_se (&parmse
, se
);
4838 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4840 else if (se
->ss
&& se
->ss
->info
->useflags
)
4846 /* An elemental function inside a scalarized loop. */
4847 gfc_init_se (&parmse
, se
);
4848 parm_kind
= ELEMENTAL
;
4850 /* When no fsym is present, ulim_copy is set and this is a third or
4851 fourth argument, use call-by-value instead of by reference to
4852 hand the length properties to the copy routine (i.e., most of the
4853 time this will be a call to a __copy_character_* routine where the
4854 third and fourth arguments are the lengths of a deferred length
4856 if ((fsym
&& fsym
->attr
.value
)
4857 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4858 gfc_conv_expr (&parmse
, e
);
4860 gfc_conv_expr_reference (&parmse
, e
);
4862 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4863 && e
->expr_type
== EXPR_FUNCTION
)
4864 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4867 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4868 && gfc_is_class_container_ref (e
))
4870 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4872 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4873 && e
->symtree
->n
.sym
->attr
.optional
)
4875 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4876 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4877 TREE_TYPE (parmse
.expr
),
4879 fold_convert (TREE_TYPE (parmse
.expr
),
4880 null_pointer_node
));
4884 /* If we are passing an absent array as optional dummy to an
4885 elemental procedure, make sure that we pass NULL when the data
4886 pointer is NULL. We need this extra conditional because of
4887 scalarization which passes arrays elements to the procedure,
4888 ignoring the fact that the array can be absent/unallocated/... */
4889 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4891 tree descriptor_data
;
4893 descriptor_data
= ss
->info
->data
.array
.data
;
4894 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4896 fold_convert (TREE_TYPE (descriptor_data
),
4897 null_pointer_node
));
4899 = fold_build3_loc (input_location
, COND_EXPR
,
4900 TREE_TYPE (parmse
.expr
),
4901 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4902 fold_convert (TREE_TYPE (parmse
.expr
),
4907 /* The scalarizer does not repackage the reference to a class
4908 array - instead it returns a pointer to the data element. */
4909 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4910 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4911 fsym
->attr
.intent
!= INTENT_IN
4912 && (CLASS_DATA (fsym
)->attr
.class_pointer
4913 || CLASS_DATA (fsym
)->attr
.allocatable
),
4915 && e
->expr_type
== EXPR_VARIABLE
4916 && e
->symtree
->n
.sym
->attr
.optional
,
4917 CLASS_DATA (fsym
)->attr
.class_pointer
4918 || CLASS_DATA (fsym
)->attr
.allocatable
);
4925 gfc_init_se (&parmse
, NULL
);
4927 /* Check whether the expression is a scalar or not; we cannot use
4928 e->rank as it can be nonzero for functions arguments. */
4929 argss
= gfc_walk_expr (e
);
4930 scalar
= argss
== gfc_ss_terminator
;
4932 gfc_free_ss_chain (argss
);
4934 /* Special handling for passing scalar polymorphic coarrays;
4935 otherwise one passes "class->_data.data" instead of "&class". */
4936 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4937 && fsym
&& fsym
->ts
.type
== BT_CLASS
4938 && CLASS_DATA (fsym
)->attr
.codimension
4939 && !CLASS_DATA (fsym
)->attr
.dimension
)
4941 gfc_add_class_array_ref (e
);
4942 parmse
.want_coarray
= 1;
4946 /* A scalar or transformational function. */
4949 if (e
->expr_type
== EXPR_VARIABLE
4950 && e
->symtree
->n
.sym
->attr
.cray_pointee
4951 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4953 /* The Cray pointer needs to be converted to a pointer to
4954 a type given by the expression. */
4955 gfc_conv_expr (&parmse
, e
);
4956 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4957 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4958 parmse
.expr
= convert (type
, tmp
);
4960 else if (fsym
&& fsym
->attr
.value
)
4962 if (fsym
->ts
.type
== BT_CHARACTER
4963 && fsym
->ts
.is_c_interop
4964 && fsym
->ns
->proc_name
!= NULL
4965 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4968 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4969 if (parmse
.expr
== NULL
)
4970 gfc_conv_expr (&parmse
, e
);
4974 gfc_conv_expr (&parmse
, e
);
4975 if (fsym
->attr
.optional
4976 && fsym
->ts
.type
!= BT_CLASS
4977 && fsym
->ts
.type
!= BT_DERIVED
)
4979 if (e
->expr_type
!= EXPR_VARIABLE
4980 || !e
->symtree
->n
.sym
->attr
.optional
4982 vec_safe_push (optionalargs
, boolean_true_node
);
4985 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4986 if (!e
->symtree
->n
.sym
->attr
.value
)
4988 = fold_build3_loc (input_location
, COND_EXPR
,
4989 TREE_TYPE (parmse
.expr
),
4991 fold_convert (TREE_TYPE (parmse
.expr
),
4992 integer_zero_node
));
4994 vec_safe_push (optionalargs
, tmp
);
4999 else if (arg
->name
&& arg
->name
[0] == '%')
5000 /* Argument list functions %VAL, %LOC and %REF are signalled
5001 through arg->name. */
5002 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5003 else if ((e
->expr_type
== EXPR_FUNCTION
)
5004 && ((e
->value
.function
.esym
5005 && e
->value
.function
.esym
->result
->attr
.pointer
)
5006 || (!e
->value
.function
.esym
5007 && e
->symtree
->n
.sym
->attr
.pointer
))
5008 && fsym
&& fsym
->attr
.target
)
5010 gfc_conv_expr (&parmse
, e
);
5011 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5013 else if (e
->expr_type
== EXPR_FUNCTION
5014 && e
->symtree
->n
.sym
->result
5015 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5016 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5018 /* Functions returning procedure pointers. */
5019 gfc_conv_expr (&parmse
, e
);
5020 if (fsym
&& fsym
->attr
.proc_pointer
)
5021 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5025 if (e
->ts
.type
== BT_CLASS
&& fsym
5026 && fsym
->ts
.type
== BT_CLASS
5027 && (!CLASS_DATA (fsym
)->as
5028 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5029 && CLASS_DATA (e
)->attr
.codimension
)
5031 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5032 gcc_assert (!CLASS_DATA (fsym
)->as
);
5033 gfc_add_class_array_ref (e
);
5034 parmse
.want_coarray
= 1;
5035 gfc_conv_expr_reference (&parmse
, e
);
5036 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5038 && e
->expr_type
== EXPR_VARIABLE
);
5040 else if (e
->ts
.type
== BT_CLASS
&& fsym
5041 && fsym
->ts
.type
== BT_CLASS
5042 && !CLASS_DATA (fsym
)->as
5043 && !CLASS_DATA (e
)->as
5044 && strcmp (fsym
->ts
.u
.derived
->name
,
5045 e
->ts
.u
.derived
->name
))
5047 type
= gfc_typenode_for_spec (&fsym
->ts
);
5048 var
= gfc_create_var (type
, fsym
->name
);
5049 gfc_conv_expr (&parmse
, e
);
5050 if (fsym
->attr
.optional
5051 && e
->expr_type
== EXPR_VARIABLE
5052 && e
->symtree
->n
.sym
->attr
.optional
)
5056 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5057 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5058 boolean_type_node
, tmp
,
5059 fold_convert (TREE_TYPE (tmp
),
5060 null_pointer_node
));
5061 gfc_start_block (&block
);
5062 gfc_add_modify (&block
, var
,
5063 fold_build1_loc (input_location
,
5065 type
, parmse
.expr
));
5066 gfc_add_expr_to_block (&parmse
.pre
,
5067 fold_build3_loc (input_location
,
5068 COND_EXPR
, void_type_node
,
5069 cond
, gfc_finish_block (&block
),
5070 build_empty_stmt (input_location
)));
5071 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5072 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5073 TREE_TYPE (parmse
.expr
),
5075 fold_convert (TREE_TYPE (parmse
.expr
),
5076 null_pointer_node
));
5080 gfc_add_modify (&parmse
.pre
, var
,
5081 fold_build1_loc (input_location
,
5083 type
, parmse
.expr
));
5084 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5088 gfc_conv_expr_reference (&parmse
, e
);
5090 /* Catch base objects that are not variables. */
5091 if (e
->ts
.type
== BT_CLASS
5092 && e
->expr_type
!= EXPR_VARIABLE
5093 && expr
&& e
== expr
->base_expr
)
5094 base_object
= build_fold_indirect_ref_loc (input_location
,
5097 /* A class array element needs converting back to be a
5098 class object, if the formal argument is a class object. */
5099 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5100 && e
->ts
.type
== BT_CLASS
5101 && ((CLASS_DATA (fsym
)->as
5102 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5103 || CLASS_DATA (e
)->attr
.dimension
))
5104 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5105 fsym
->attr
.intent
!= INTENT_IN
5106 && (CLASS_DATA (fsym
)->attr
.class_pointer
5107 || CLASS_DATA (fsym
)->attr
.allocatable
),
5109 && e
->expr_type
== EXPR_VARIABLE
5110 && e
->symtree
->n
.sym
->attr
.optional
,
5111 CLASS_DATA (fsym
)->attr
.class_pointer
5112 || CLASS_DATA (fsym
)->attr
.allocatable
);
5114 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5115 allocated on entry, it must be deallocated. */
5116 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5117 && (fsym
->attr
.allocatable
5118 || (fsym
->ts
.type
== BT_CLASS
5119 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5124 gfc_init_block (&block
);
5126 if (e
->ts
.type
== BT_CLASS
)
5127 ptr
= gfc_class_data_get (ptr
);
5129 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5131 gfc_add_expr_to_block (&block
, tmp
);
5132 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5133 void_type_node
, ptr
,
5135 gfc_add_expr_to_block (&block
, tmp
);
5137 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5139 gfc_add_modify (&block
, ptr
,
5140 fold_convert (TREE_TYPE (ptr
),
5141 null_pointer_node
));
5142 gfc_add_expr_to_block (&block
, tmp
);
5144 else if (fsym
->ts
.type
== BT_CLASS
)
5147 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5148 tmp
= gfc_get_symbol_decl (vtab
);
5149 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5150 ptr
= gfc_class_vptr_get (parmse
.expr
);
5151 gfc_add_modify (&block
, ptr
,
5152 fold_convert (TREE_TYPE (ptr
), tmp
));
5153 gfc_add_expr_to_block (&block
, tmp
);
5156 if (fsym
->attr
.optional
5157 && e
->expr_type
== EXPR_VARIABLE
5158 && e
->symtree
->n
.sym
->attr
.optional
)
5160 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5162 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5163 gfc_finish_block (&block
),
5164 build_empty_stmt (input_location
));
5167 tmp
= gfc_finish_block (&block
);
5169 gfc_add_expr_to_block (&se
->pre
, tmp
);
5172 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5173 || fsym
->ts
.type
== BT_ASSUMED
)
5174 && e
->ts
.type
== BT_CLASS
5175 && !CLASS_DATA (e
)->attr
.dimension
5176 && !CLASS_DATA (e
)->attr
.codimension
)
5177 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5179 /* Wrap scalar variable in a descriptor. We need to convert
5180 the address of a pointer back to the pointer itself before,
5181 we can assign it to the data field. */
5183 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5184 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5187 if (TREE_CODE (tmp
) == ADDR_EXPR
5188 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5189 tmp
= TREE_OPERAND (tmp
, 0);
5190 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5192 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5195 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5196 && ((fsym
->attr
.pointer
5197 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5198 || (fsym
->attr
.proc_pointer
5199 && !(e
->expr_type
== EXPR_VARIABLE
5200 && e
->symtree
->n
.sym
->attr
.dummy
))
5201 || (fsym
->attr
.proc_pointer
5202 && e
->expr_type
== EXPR_VARIABLE
5203 && gfc_is_proc_ptr_comp (e
))
5204 || (fsym
->attr
.allocatable
5205 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5207 /* Scalar pointer dummy args require an extra level of
5208 indirection. The null pointer already contains
5209 this level of indirection. */
5210 parm_kind
= SCALAR_POINTER
;
5211 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5215 else if (e
->ts
.type
== BT_CLASS
5216 && fsym
&& fsym
->ts
.type
== BT_CLASS
5217 && (CLASS_DATA (fsym
)->attr
.dimension
5218 || CLASS_DATA (fsym
)->attr
.codimension
))
5220 /* Pass a class array. */
5221 parmse
.use_offset
= 1;
5222 gfc_conv_expr_descriptor (&parmse
, e
);
5224 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5225 allocated on entry, it must be deallocated. */
5226 if (fsym
->attr
.intent
== INTENT_OUT
5227 && CLASS_DATA (fsym
)->attr
.allocatable
)
5232 gfc_init_block (&block
);
5234 ptr
= gfc_class_data_get (ptr
);
5236 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5237 NULL_TREE
, NULL_TREE
,
5240 gfc_add_expr_to_block (&block
, tmp
);
5241 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5242 void_type_node
, ptr
,
5244 gfc_add_expr_to_block (&block
, tmp
);
5245 gfc_reset_vptr (&block
, e
);
5247 if (fsym
->attr
.optional
5248 && e
->expr_type
== EXPR_VARIABLE
5250 || (e
->ref
->type
== REF_ARRAY
5251 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5252 && e
->symtree
->n
.sym
->attr
.optional
)
5254 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5256 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5257 gfc_finish_block (&block
),
5258 build_empty_stmt (input_location
));
5261 tmp
= gfc_finish_block (&block
);
5263 gfc_add_expr_to_block (&se
->pre
, tmp
);
5266 /* The conversion does not repackage the reference to a class
5267 array - _data descriptor. */
5268 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5269 fsym
->attr
.intent
!= INTENT_IN
5270 && (CLASS_DATA (fsym
)->attr
.class_pointer
5271 || CLASS_DATA (fsym
)->attr
.allocatable
),
5273 && e
->expr_type
== EXPR_VARIABLE
5274 && e
->symtree
->n
.sym
->attr
.optional
,
5275 CLASS_DATA (fsym
)->attr
.class_pointer
5276 || CLASS_DATA (fsym
)->attr
.allocatable
);
5280 /* If the argument is a function call that may not create
5281 a temporary for the result, we have to check that we
5282 can do it, i.e. that there is no alias between this
5283 argument and another one. */
5284 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5290 intent
= fsym
->attr
.intent
;
5292 intent
= INTENT_UNKNOWN
;
5294 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5296 parmse
.force_tmp
= 1;
5298 iarg
= e
->value
.function
.actual
->expr
;
5300 /* Temporary needed if aliasing due to host association. */
5301 if (sym
->attr
.contained
5303 && !sym
->attr
.implicit_pure
5304 && !sym
->attr
.use_assoc
5305 && iarg
->expr_type
== EXPR_VARIABLE
5306 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5307 parmse
.force_tmp
= 1;
5309 /* Ditto within module. */
5310 if (sym
->attr
.use_assoc
5312 && !sym
->attr
.implicit_pure
5313 && iarg
->expr_type
== EXPR_VARIABLE
5314 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5315 parmse
.force_tmp
= 1;
5318 if (e
->expr_type
== EXPR_VARIABLE
5319 && is_subref_array (e
))
5320 /* The actual argument is a component reference to an
5321 array of derived types. In this case, the argument
5322 is converted to a temporary, which is passed and then
5323 written back after the procedure call. */
5324 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5325 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5326 fsym
&& fsym
->attr
.pointer
);
5327 else if (gfc_is_class_array_ref (e
, NULL
)
5328 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5329 /* The actual argument is a component reference to an
5330 array of derived types. In this case, the argument
5331 is converted to a temporary, which is passed and then
5332 written back after the procedure call.
5333 OOP-TODO: Insert code so that if the dynamic type is
5334 the same as the declared type, copy-in/copy-out does
5336 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5337 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5338 fsym
&& fsym
->attr
.pointer
);
5340 else if (gfc_is_alloc_class_array_function (e
)
5341 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5342 /* See previous comment. For function actual argument,
5343 the write out is not needed so the intent is set as
5346 e
->must_finalize
= 1;
5347 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5349 fsym
&& fsym
->attr
.pointer
);
5352 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5355 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5356 allocated on entry, it must be deallocated. */
5357 if (fsym
&& fsym
->attr
.allocatable
5358 && fsym
->attr
.intent
== INTENT_OUT
)
5360 tmp
= build_fold_indirect_ref_loc (input_location
,
5362 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5363 if (fsym
->attr
.optional
5364 && e
->expr_type
== EXPR_VARIABLE
5365 && e
->symtree
->n
.sym
->attr
.optional
)
5366 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5368 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5369 tmp
, build_empty_stmt (input_location
));
5370 gfc_add_expr_to_block (&se
->pre
, tmp
);
5375 /* The case with fsym->attr.optional is that of a user subroutine
5376 with an interface indicating an optional argument. When we call
5377 an intrinsic subroutine, however, fsym is NULL, but we might still
5378 have an optional argument, so we proceed to the substitution
5380 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5382 /* If an optional argument is itself an optional dummy argument,
5383 check its presence and substitute a null if absent. This is
5384 only needed when passing an array to an elemental procedure
5385 as then array elements are accessed - or no NULL pointer is
5386 allowed and a "1" or "0" should be passed if not present.
5387 When passing a non-array-descriptor full array to a
5388 non-array-descriptor dummy, no check is needed. For
5389 array-descriptor actual to array-descriptor dummy, see
5390 PR 41911 for why a check has to be inserted.
5391 fsym == NULL is checked as intrinsics required the descriptor
5392 but do not always set fsym. */
5393 if (e
->expr_type
== EXPR_VARIABLE
5394 && e
->symtree
->n
.sym
->attr
.optional
5395 && ((e
->rank
!= 0 && elemental_proc
)
5396 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5400 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5401 || fsym
->as
->type
== AS_ASSUMED_RANK
5402 || fsym
->as
->type
== AS_DEFERRED
))))))
5403 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5404 e
->representation
.length
);
5409 /* Obtain the character length of an assumed character length
5410 length procedure from the typespec. */
5411 if (fsym
->ts
.type
== BT_CHARACTER
5412 && parmse
.string_length
== NULL_TREE
5413 && e
->ts
.type
== BT_PROCEDURE
5414 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5415 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5416 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5418 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5419 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5423 if (fsym
&& need_interface_mapping
&& e
)
5424 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5426 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5427 gfc_add_block_to_block (&post
, &parmse
.post
);
5429 /* Allocated allocatable components of derived types must be
5430 deallocated for non-variable scalars, array arguments to elemental
5431 procedures, and array arguments with descriptor to non-elemental
5432 procedures. As bounds information for descriptorless arrays is no
5433 longer available here, they are dealt with in trans-array.c
5434 (gfc_conv_array_parameter). */
5435 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5436 && e
->ts
.u
.derived
->attr
.alloc_comp
5437 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5438 && !expr_may_alias_variables (e
, elemental_proc
))
5441 /* It is known the e returns a structure type with at least one
5442 allocatable component. When e is a function, ensure that the
5443 function is called once only by using a temporary variable. */
5444 if (!DECL_P (parmse
.expr
))
5445 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5446 parmse
.expr
, &se
->pre
);
5448 if (fsym
&& fsym
->attr
.value
)
5451 tmp
= build_fold_indirect_ref_loc (input_location
,
5454 parm_rank
= e
->rank
;
5462 case (SCALAR_POINTER
):
5463 tmp
= build_fold_indirect_ref_loc (input_location
,
5468 if (e
->expr_type
== EXPR_OP
5469 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5470 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5473 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5474 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5475 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5478 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5480 /* The derived type is passed to gfc_deallocate_alloc_comp.
5481 Therefore, class actuals can handled correctly but derived
5482 types passed to class formals need the _data component. */
5483 tmp
= gfc_class_data_get (tmp
);
5484 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5485 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5488 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5490 gfc_add_expr_to_block (&se
->post
, tmp
);
5493 /* Add argument checking of passing an unallocated/NULL actual to
5494 a nonallocatable/nonpointer dummy. */
5496 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5498 symbol_attribute attr
;
5502 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5503 attr
= gfc_expr_attr (e
);
5505 goto end_pointer_check
;
5507 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5508 allocatable to an optional dummy, cf. 12.5.2.12. */
5509 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5510 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5511 goto end_pointer_check
;
5515 /* If the actual argument is an optional pointer/allocatable and
5516 the formal argument takes an nonpointer optional value,
5517 it is invalid to pass a non-present argument on, even
5518 though there is no technical reason for this in gfortran.
5519 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5520 tree present
, null_ptr
, type
;
5522 if (attr
.allocatable
5523 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5524 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5525 "allocated or not present",
5526 e
->symtree
->n
.sym
->name
);
5527 else if (attr
.pointer
5528 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5529 msg
= xasprintf ("Pointer actual argument '%s' is not "
5530 "associated or not present",
5531 e
->symtree
->n
.sym
->name
);
5532 else if (attr
.proc_pointer
5533 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5534 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5535 "associated or not present",
5536 e
->symtree
->n
.sym
->name
);
5538 goto end_pointer_check
;
5540 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5541 type
= TREE_TYPE (present
);
5542 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5543 boolean_type_node
, present
,
5545 null_pointer_node
));
5546 type
= TREE_TYPE (parmse
.expr
);
5547 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5548 boolean_type_node
, parmse
.expr
,
5550 null_pointer_node
));
5551 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5552 boolean_type_node
, present
, null_ptr
);
5556 if (attr
.allocatable
5557 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5558 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5559 "allocated", e
->symtree
->n
.sym
->name
);
5560 else if (attr
.pointer
5561 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5562 msg
= xasprintf ("Pointer actual argument '%s' is not "
5563 "associated", e
->symtree
->n
.sym
->name
);
5564 else if (attr
.proc_pointer
5565 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5566 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5567 "associated", e
->symtree
->n
.sym
->name
);
5569 goto end_pointer_check
;
5573 /* If the argument is passed by value, we need to strip the
5575 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5576 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5578 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5579 boolean_type_node
, tmp
,
5580 fold_convert (TREE_TYPE (tmp
),
5581 null_pointer_node
));
5584 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5590 /* Deferred length dummies pass the character length by reference
5591 so that the value can be returned. */
5592 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5594 if (INDIRECT_REF_P (parmse
.string_length
))
5595 /* In chains of functions/procedure calls the string_length already
5596 is a pointer to the variable holding the length. Therefore
5597 remove the deref on call. */
5598 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5601 tmp
= parmse
.string_length
;
5602 if (TREE_CODE (tmp
) != VAR_DECL
5603 && TREE_CODE (tmp
) != COMPONENT_REF
)
5604 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5605 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5609 /* Character strings are passed as two parameters, a length and a
5610 pointer - except for Bind(c) which only passes the pointer.
5611 An unlimited polymorphic formal argument likewise does not
5613 if (parmse
.string_length
!= NULL_TREE
5614 && !sym
->attr
.is_bind_c
5615 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5616 vec_safe_push (stringargs
, parmse
.string_length
);
5618 /* When calling __copy for character expressions to unlimited
5619 polymorphic entities, the dst argument needs a string length. */
5620 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5621 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5622 && arg
->next
&& arg
->next
->expr
5623 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5624 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5625 vec_safe_push (stringargs
, parmse
.string_length
);
5627 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5628 pass the token and the offset as additional arguments. */
5629 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5630 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5631 && !fsym
->attr
.allocatable
)
5632 || (fsym
->ts
.type
== BT_CLASS
5633 && CLASS_DATA (fsym
)->attr
.codimension
5634 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5636 /* Token and offset. */
5637 vec_safe_push (stringargs
, null_pointer_node
);
5638 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5639 gcc_assert (fsym
->attr
.optional
);
5641 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5642 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5643 && !fsym
->attr
.allocatable
)
5644 || (fsym
->ts
.type
== BT_CLASS
5645 && CLASS_DATA (fsym
)->attr
.codimension
5646 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5648 tree caf_decl
, caf_type
;
5651 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5652 caf_type
= TREE_TYPE (caf_decl
);
5654 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5655 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5656 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5657 tmp
= gfc_conv_descriptor_token (caf_decl
);
5658 else if (DECL_LANG_SPECIFIC (caf_decl
)
5659 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5660 tmp
= GFC_DECL_TOKEN (caf_decl
);
5663 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5664 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5665 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5668 vec_safe_push (stringargs
, tmp
);
5670 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5671 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5672 offset
= build_int_cst (gfc_array_index_type
, 0);
5673 else if (DECL_LANG_SPECIFIC (caf_decl
)
5674 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5675 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5676 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5677 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5679 offset
= build_int_cst (gfc_array_index_type
, 0);
5681 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5682 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5685 gcc_assert (POINTER_TYPE_P (caf_type
));
5689 tmp2
= fsym
->ts
.type
== BT_CLASS
5690 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5691 if ((fsym
->ts
.type
!= BT_CLASS
5692 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5693 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5694 || (fsym
->ts
.type
== BT_CLASS
5695 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5696 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5698 if (fsym
->ts
.type
== BT_CLASS
)
5699 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5702 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5703 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5705 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5706 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5708 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5709 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5712 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5715 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5716 gfc_array_index_type
,
5717 fold_convert (gfc_array_index_type
, tmp2
),
5718 fold_convert (gfc_array_index_type
, tmp
));
5719 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5720 gfc_array_index_type
, offset
, tmp
);
5722 vec_safe_push (stringargs
, offset
);
5725 vec_safe_push (arglist
, parmse
.expr
);
5727 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5734 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5735 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5736 else if (ts
.type
== BT_CHARACTER
)
5738 if (ts
.u
.cl
->length
== NULL
)
5740 /* Assumed character length results are not allowed by 5.1.1.5 of the
5741 standard and are trapped in resolve.c; except in the case of SPREAD
5742 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5743 we take the character length of the first argument for the result.
5744 For dummies, we have to look through the formal argument list for
5745 this function and use the character length found there.*/
5747 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5748 else if (!sym
->attr
.dummy
)
5749 cl
.backend_decl
= (*stringargs
)[0];
5752 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5753 for (; formal
; formal
= formal
->next
)
5754 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5755 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5757 len
= cl
.backend_decl
;
5763 /* Calculate the length of the returned string. */
5764 gfc_init_se (&parmse
, NULL
);
5765 if (need_interface_mapping
)
5766 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5768 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5769 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5770 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5772 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5773 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5774 gfc_charlen_type_node
, tmp
,
5775 build_int_cst (gfc_charlen_type_node
, 0));
5776 cl
.backend_decl
= tmp
;
5779 /* Set up a charlen structure for it. */
5784 len
= cl
.backend_decl
;
5787 byref
= (comp
&& (comp
->attr
.dimension
5788 || (comp
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)))
5789 || (!comp
&& gfc_return_by_reference (sym
));
5792 if (se
->direct_byref
)
5794 /* Sometimes, too much indirection can be applied; e.g. for
5795 function_result = array_valued_recursive_function. */
5796 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5797 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5798 && GFC_DESCRIPTOR_TYPE_P
5799 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5800 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5803 /* If the lhs of an assignment x = f(..) is allocatable and
5804 f2003 is allowed, we must do the automatic reallocation.
5805 TODO - deal with intrinsics, without using a temporary. */
5806 if (flag_realloc_lhs
5807 && se
->ss
&& se
->ss
->loop_chain
5808 && se
->ss
->loop_chain
->is_alloc_lhs
5809 && !expr
->value
.function
.isym
5810 && sym
->result
->as
!= NULL
)
5812 /* Evaluate the bounds of the result, if known. */
5813 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5816 /* Perform the automatic reallocation. */
5817 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5819 gfc_add_expr_to_block (&se
->pre
, tmp
);
5821 /* Pass the temporary as the first argument. */
5822 result
= info
->descriptor
;
5825 result
= build_fold_indirect_ref_loc (input_location
,
5827 vec_safe_push (retargs
, se
->expr
);
5829 else if (comp
&& comp
->attr
.dimension
)
5831 gcc_assert (se
->loop
&& info
);
5833 /* Set the type of the array. */
5834 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5835 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5837 /* Evaluate the bounds of the result, if known. */
5838 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5840 /* If the lhs of an assignment x = f(..) is allocatable and
5841 f2003 is allowed, we must not generate the function call
5842 here but should just send back the results of the mapping.
5843 This is signalled by the function ss being flagged. */
5844 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5846 gfc_free_interface_mapping (&mapping
);
5847 return has_alternate_specifier
;
5850 /* Create a temporary to store the result. In case the function
5851 returns a pointer, the temporary will be a shallow copy and
5852 mustn't be deallocated. */
5853 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5854 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5855 tmp
, NULL_TREE
, false,
5856 !comp
->attr
.pointer
, callee_alloc
,
5857 &se
->ss
->info
->expr
->where
);
5859 /* Pass the temporary as the first argument. */
5860 result
= info
->descriptor
;
5861 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5862 vec_safe_push (retargs
, tmp
);
5864 else if (!comp
&& sym
->result
->attr
.dimension
)
5866 gcc_assert (se
->loop
&& info
);
5868 /* Set the type of the array. */
5869 tmp
= gfc_typenode_for_spec (&ts
);
5870 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5872 /* Evaluate the bounds of the result, if known. */
5873 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5875 /* If the lhs of an assignment x = f(..) is allocatable and
5876 f2003 is allowed, we must not generate the function call
5877 here but should just send back the results of the mapping.
5878 This is signalled by the function ss being flagged. */
5879 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5881 gfc_free_interface_mapping (&mapping
);
5882 return has_alternate_specifier
;
5885 /* Create a temporary to store the result. In case the function
5886 returns a pointer, the temporary will be a shallow copy and
5887 mustn't be deallocated. */
5888 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5889 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5890 tmp
, NULL_TREE
, false,
5891 !sym
->attr
.pointer
, callee_alloc
,
5892 &se
->ss
->info
->expr
->where
);
5894 /* Pass the temporary as the first argument. */
5895 result
= info
->descriptor
;
5896 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5897 vec_safe_push (retargs
, tmp
);
5899 else if (ts
.type
== BT_CHARACTER
)
5901 /* Pass the string length. */
5902 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5903 type
= build_pointer_type (type
);
5905 /* Return an address to a char[0:len-1]* temporary for
5906 character pointers. */
5907 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5908 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5910 var
= gfc_create_var (type
, "pstr");
5912 if ((!comp
&& sym
->attr
.allocatable
)
5913 || (comp
&& comp
->attr
.allocatable
))
5915 gfc_add_modify (&se
->pre
, var
,
5916 fold_convert (TREE_TYPE (var
),
5917 null_pointer_node
));
5918 tmp
= gfc_call_free (var
);
5919 gfc_add_expr_to_block (&se
->post
, tmp
);
5922 /* Provide an address expression for the function arguments. */
5923 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5926 var
= gfc_conv_string_tmp (se
, type
, len
);
5928 vec_safe_push (retargs
, var
);
5932 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5934 type
= gfc_get_complex_type (ts
.kind
);
5935 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5936 vec_safe_push (retargs
, var
);
5939 /* Add the string length to the argument list. */
5940 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5943 if (TREE_CODE (tmp
) != VAR_DECL
)
5944 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5945 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5946 vec_safe_push (retargs
, tmp
);
5948 else if (ts
.type
== BT_CHARACTER
)
5949 vec_safe_push (retargs
, len
);
5951 gfc_free_interface_mapping (&mapping
);
5953 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5954 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5955 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5956 vec_safe_reserve (retargs
, arglen
);
5958 /* Add the return arguments. */
5959 vec_safe_splice (retargs
, arglist
);
5961 /* Add the hidden present status for optional+value to the arguments. */
5962 vec_safe_splice (retargs
, optionalargs
);
5964 /* Add the hidden string length parameters to the arguments. */
5965 vec_safe_splice (retargs
, stringargs
);
5967 /* We may want to append extra arguments here. This is used e.g. for
5968 calls to libgfortran_matmul_??, which need extra information. */
5969 vec_safe_splice (retargs
, append_args
);
5973 /* Generate the actual call. */
5974 if (base_object
== NULL_TREE
)
5975 conv_function_val (se
, sym
, expr
);
5977 conv_base_obj_fcn_val (se
, base_object
, expr
);
5979 /* If there are alternate return labels, function type should be
5980 integer. Can't modify the type in place though, since it can be shared
5981 with other functions. For dummy arguments, the typing is done to
5982 this result, even if it has to be repeated for each call. */
5983 if (has_alternate_specifier
5984 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5986 if (!sym
->attr
.dummy
)
5988 TREE_TYPE (sym
->backend_decl
)
5989 = build_function_type (integer_type_node
,
5990 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5991 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5994 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5997 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5998 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6000 /* Allocatable scalar function results must be freed and nullified
6001 after use. This necessitates the creation of a temporary to
6002 hold the result to prevent duplicate calls. */
6003 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6004 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6006 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6007 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6009 tmp
= gfc_call_free (tmp
);
6010 gfc_add_expr_to_block (&post
, tmp
);
6011 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6014 /* If we have a pointer function, but we don't want a pointer, e.g.
6017 where f is pointer valued, we have to dereference the result. */
6018 if (!se
->want_pointer
&& !byref
6019 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6020 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6021 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6023 /* f2c calling conventions require a scalar default real function to
6024 return a double precision result. Convert this back to default
6025 real. We only care about the cases that can happen in Fortran 77.
6027 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6028 && sym
->ts
.kind
== gfc_default_real_kind
6029 && !sym
->attr
.always_explicit
)
6030 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6032 /* A pure function may still have side-effects - it may modify its
6034 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6036 if (!sym
->attr
.pure
)
6037 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6042 /* Add the function call to the pre chain. There is no expression. */
6043 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6044 se
->expr
= NULL_TREE
;
6046 if (!se
->direct_byref
)
6048 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6050 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6052 /* Check the data pointer hasn't been modified. This would
6053 happen in a function returning a pointer. */
6054 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6055 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6058 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6061 se
->expr
= info
->descriptor
;
6062 /* Bundle in the string length. */
6063 se
->string_length
= len
;
6065 else if (ts
.type
== BT_CHARACTER
)
6067 /* Dereference for character pointer results. */
6068 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6069 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6070 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6074 se
->string_length
= len
;
6078 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6079 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6084 /* Follow the function call with the argument post block. */
6087 gfc_add_block_to_block (&se
->pre
, &post
);
6089 /* Transformational functions of derived types with allocatable
6090 components must have the result allocatable components copied. */
6091 arg
= expr
->value
.function
.actual
;
6092 if (result
&& arg
&& expr
->rank
6093 && expr
->value
.function
.isym
6094 && expr
->value
.function
.isym
->transformational
6095 && arg
->expr
->ts
.type
== BT_DERIVED
6096 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6099 /* Copy the allocatable components. We have to use a
6100 temporary here to prevent source allocatable components
6101 from being corrupted. */
6102 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6103 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6104 result
, tmp2
, expr
->rank
);
6105 gfc_add_expr_to_block (&se
->pre
, tmp
);
6106 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6108 gfc_add_expr_to_block (&se
->pre
, tmp
);
6110 /* Finally free the temporary's data field. */
6111 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6112 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6113 NULL_TREE
, NULL_TREE
, true,
6115 gfc_add_expr_to_block (&se
->pre
, tmp
);
6120 /* For a function with a class array result, save the result as
6121 a temporary, set the info fields needed by the scalarizer and
6122 call the finalization function of the temporary. Note that the
6123 nullification of allocatable components needed by the result
6124 is done in gfc_trans_assignment_1. */
6125 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6126 && se
->ss
&& se
->ss
->loop
)
6127 || gfc_is_alloc_class_scalar_function (expr
))
6128 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6129 && expr
->must_finalize
)
6134 if (se
->ss
&& se
->ss
->loop
)
6136 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6137 tmp
= gfc_class_data_get (se
->expr
);
6138 info
->descriptor
= tmp
;
6139 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6140 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6141 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6143 tree dim
= gfc_rank_cst
[n
];
6144 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6145 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6150 /* TODO Eliminate the doubling of temporaries. This
6151 one is necessary to ensure no memory leakage. */
6152 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6153 tmp
= gfc_class_data_get (se
->expr
);
6154 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6155 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6158 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6159 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6162 fold_convert (TREE_TYPE (final_fndecl
),
6163 null_pointer_node
));
6164 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6166 tmp
= build_call_expr_loc (input_location
,
6168 gfc_build_addr_expr (NULL
, tmp
),
6169 gfc_class_vtab_size_get (se
->expr
),
6170 boolean_false_node
);
6171 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6172 void_type_node
, is_final
, tmp
,
6173 build_empty_stmt (input_location
));
6175 if (se
->ss
&& se
->ss
->loop
)
6177 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6178 tmp
= gfc_call_free (info
->data
);
6179 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6183 gfc_add_expr_to_block (&se
->post
, tmp
);
6184 tmp
= gfc_class_data_get (se
->expr
);
6185 tmp
= gfc_call_free (tmp
);
6186 gfc_add_expr_to_block (&se
->post
, tmp
);
6188 expr
->must_finalize
= 0;
6191 gfc_add_block_to_block (&se
->post
, &post
);
6194 return has_alternate_specifier
;
6198 /* Fill a character string with spaces. */
6201 fill_with_spaces (tree start
, tree type
, tree size
)
6203 stmtblock_t block
, loop
;
6204 tree i
, el
, exit_label
, cond
, tmp
;
6206 /* For a simple char type, we can call memset(). */
6207 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6208 return build_call_expr_loc (input_location
,
6209 builtin_decl_explicit (BUILT_IN_MEMSET
),
6211 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6212 lang_hooks
.to_target_charset (' ')),
6215 /* Otherwise, we use a loop:
6216 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6220 /* Initialize variables. */
6221 gfc_init_block (&block
);
6222 i
= gfc_create_var (sizetype
, "i");
6223 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6224 el
= gfc_create_var (build_pointer_type (type
), "el");
6225 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6226 exit_label
= gfc_build_label_decl (NULL_TREE
);
6227 TREE_USED (exit_label
) = 1;
6231 gfc_init_block (&loop
);
6233 /* Exit condition. */
6234 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6235 build_zero_cst (sizetype
));
6236 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6237 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6238 build_empty_stmt (input_location
));
6239 gfc_add_expr_to_block (&loop
, tmp
);
6242 gfc_add_modify (&loop
,
6243 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6244 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6246 /* Increment loop variables. */
6247 gfc_add_modify (&loop
, i
,
6248 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6249 TYPE_SIZE_UNIT (type
)));
6250 gfc_add_modify (&loop
, el
,
6251 fold_build_pointer_plus_loc (input_location
,
6252 el
, TYPE_SIZE_UNIT (type
)));
6254 /* Making the loop... actually loop! */
6255 tmp
= gfc_finish_block (&loop
);
6256 tmp
= build1_v (LOOP_EXPR
, tmp
);
6257 gfc_add_expr_to_block (&block
, tmp
);
6259 /* The exit label. */
6260 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6261 gfc_add_expr_to_block (&block
, tmp
);
6264 return gfc_finish_block (&block
);
6268 /* Generate code to copy a string. */
6271 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6272 int dkind
, tree slength
, tree src
, int skind
)
6274 tree tmp
, dlen
, slen
;
6283 stmtblock_t tempblock
;
6285 gcc_assert (dkind
== skind
);
6287 if (slength
!= NULL_TREE
)
6289 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6290 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6294 slen
= build_int_cst (size_type_node
, 1);
6298 if (dlength
!= NULL_TREE
)
6300 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6301 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6305 dlen
= build_int_cst (size_type_node
, 1);
6309 /* Assign directly if the types are compatible. */
6310 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6311 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6313 gfc_add_modify (block
, dsc
, ssc
);
6317 /* Do nothing if the destination length is zero. */
6318 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6319 build_int_cst (size_type_node
, 0));
6321 /* The following code was previously in _gfortran_copy_string:
6323 // The two strings may overlap so we use memmove.
6325 copy_string (GFC_INTEGER_4 destlen, char * dest,
6326 GFC_INTEGER_4 srclen, const char * src)
6328 if (srclen >= destlen)
6330 // This will truncate if too long.
6331 memmove (dest, src, destlen);
6335 memmove (dest, src, srclen);
6337 memset (&dest[srclen], ' ', destlen - srclen);
6341 We're now doing it here for better optimization, but the logic
6344 /* For non-default character kinds, we have to multiply the string
6345 length by the base type size. */
6346 chartype
= gfc_get_char_type (dkind
);
6347 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6348 fold_convert (size_type_node
, slen
),
6349 fold_convert (size_type_node
,
6350 TYPE_SIZE_UNIT (chartype
)));
6351 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6352 fold_convert (size_type_node
, dlen
),
6353 fold_convert (size_type_node
,
6354 TYPE_SIZE_UNIT (chartype
)));
6356 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6357 dest
= fold_convert (pvoid_type_node
, dest
);
6359 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6361 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6362 src
= fold_convert (pvoid_type_node
, src
);
6364 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6366 /* Truncate string if source is too long. */
6367 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6369 tmp2
= build_call_expr_loc (input_location
,
6370 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6371 3, dest
, src
, dlen
);
6373 /* Else copy and pad with spaces. */
6374 tmp3
= build_call_expr_loc (input_location
,
6375 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6376 3, dest
, src
, slen
);
6378 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6379 tmp4
= fill_with_spaces (tmp4
, chartype
,
6380 fold_build2_loc (input_location
, MINUS_EXPR
,
6381 TREE_TYPE(dlen
), dlen
, slen
));
6383 gfc_init_block (&tempblock
);
6384 gfc_add_expr_to_block (&tempblock
, tmp3
);
6385 gfc_add_expr_to_block (&tempblock
, tmp4
);
6386 tmp3
= gfc_finish_block (&tempblock
);
6388 /* The whole copy_string function is there. */
6389 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6391 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6392 build_empty_stmt (input_location
));
6393 gfc_add_expr_to_block (block
, tmp
);
6397 /* Translate a statement function.
6398 The value of a statement function reference is obtained by evaluating the
6399 expression using the values of the actual arguments for the values of the
6400 corresponding dummy arguments. */
6403 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6407 gfc_formal_arglist
*fargs
;
6408 gfc_actual_arglist
*args
;
6411 gfc_saved_var
*saved_vars
;
6417 sym
= expr
->symtree
->n
.sym
;
6418 args
= expr
->value
.function
.actual
;
6419 gfc_init_se (&lse
, NULL
);
6420 gfc_init_se (&rse
, NULL
);
6423 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6425 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6426 temp_vars
= XCNEWVEC (tree
, n
);
6428 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6429 fargs
= fargs
->next
, n
++)
6431 /* Each dummy shall be specified, explicitly or implicitly, to be
6433 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6436 if (fsym
->ts
.type
== BT_CHARACTER
)
6438 /* Copy string arguments. */
6441 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6442 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6444 /* Create a temporary to hold the value. */
6445 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6446 fsym
->ts
.u
.cl
->backend_decl
6447 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6449 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6450 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6452 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6454 gfc_conv_expr (&rse
, args
->expr
);
6455 gfc_conv_string_parameter (&rse
);
6456 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6457 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6459 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6460 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6461 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6462 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6466 /* For everything else, just evaluate the expression. */
6468 /* Create a temporary to hold the value. */
6469 type
= gfc_typenode_for_spec (&fsym
->ts
);
6470 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6472 gfc_conv_expr (&lse
, args
->expr
);
6474 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6475 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6476 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6482 /* Use the temporary variables in place of the real ones. */
6483 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6484 fargs
= fargs
->next
, n
++)
6485 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6487 gfc_conv_expr (se
, sym
->value
);
6489 if (sym
->ts
.type
== BT_CHARACTER
)
6491 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6493 /* Force the expression to the correct length. */
6494 if (!INTEGER_CST_P (se
->string_length
)
6495 || tree_int_cst_lt (se
->string_length
,
6496 sym
->ts
.u
.cl
->backend_decl
))
6498 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6499 tmp
= gfc_create_var (type
, sym
->name
);
6500 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6501 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6502 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6506 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6509 /* Restore the original variables. */
6510 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6511 fargs
= fargs
->next
, n
++)
6512 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6518 /* Translate a function expression. */
6521 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6525 if (expr
->value
.function
.isym
)
6527 gfc_conv_intrinsic_function (se
, expr
);
6531 /* expr.value.function.esym is the resolved (specific) function symbol for
6532 most functions. However this isn't set for dummy procedures. */
6533 sym
= expr
->value
.function
.esym
;
6535 sym
= expr
->symtree
->n
.sym
;
6537 /* The IEEE_ARITHMETIC functions are caught here. */
6538 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6539 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6542 /* We distinguish statement functions from general functions to improve
6543 runtime performance. */
6544 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6546 gfc_conv_statement_function (se
, expr
);
6550 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6555 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6558 is_zero_initializer_p (gfc_expr
* expr
)
6560 if (expr
->expr_type
!= EXPR_CONSTANT
)
6563 /* We ignore constants with prescribed memory representations for now. */
6564 if (expr
->representation
.string
)
6567 switch (expr
->ts
.type
)
6570 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6573 return mpfr_zero_p (expr
->value
.real
)
6574 && MPFR_SIGN (expr
->value
.real
) >= 0;
6577 return expr
->value
.logical
== 0;
6580 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6581 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6582 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6583 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6593 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6598 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6599 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6601 gfc_conv_tmp_array_ref (se
);
6605 /* Build a static initializer. EXPR is the expression for the initial value.
6606 The other parameters describe the variable of the component being
6607 initialized. EXPR may be null. */
6610 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6611 bool array
, bool pointer
, bool procptr
)
6615 if (flag_coarray
!= GFC_FCOARRAY_LIB
&& ts
->type
== BT_DERIVED
6616 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6617 && ts
->u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
6618 return build_constructor (type
, NULL
);
6620 if (!(expr
|| pointer
|| procptr
))
6623 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6624 (these are the only two iso_c_binding derived types that can be
6625 used as initialization expressions). If so, we need to modify
6626 the 'expr' to be that for a (void *). */
6627 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6628 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6630 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6632 /* The derived symbol has already been converted to a (void *). Use
6634 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6635 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6637 gfc_init_se (&se
, NULL
);
6638 gfc_conv_constant (&se
, expr
);
6639 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6643 if (array
&& !procptr
)
6646 /* Arrays need special handling. */
6648 ctor
= gfc_build_null_descriptor (type
);
6649 /* Special case assigning an array to zero. */
6650 else if (is_zero_initializer_p (expr
))
6651 ctor
= build_constructor (type
, NULL
);
6653 ctor
= gfc_conv_array_initializer (type
, expr
);
6654 TREE_STATIC (ctor
) = 1;
6657 else if (pointer
|| procptr
)
6659 if (ts
->type
== BT_CLASS
&& !procptr
)
6661 gfc_init_se (&se
, NULL
);
6662 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6663 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6664 TREE_STATIC (se
.expr
) = 1;
6667 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6668 return fold_convert (type
, null_pointer_node
);
6671 gfc_init_se (&se
, NULL
);
6672 se
.want_pointer
= 1;
6673 gfc_conv_expr (&se
, expr
);
6674 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6684 gfc_init_se (&se
, NULL
);
6685 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6686 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6688 gfc_conv_structure (&se
, expr
, 1);
6689 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6690 TREE_STATIC (se
.expr
) = 1;
6695 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6696 TREE_STATIC (ctor
) = 1;
6701 gfc_init_se (&se
, NULL
);
6702 gfc_conv_constant (&se
, expr
);
6703 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6710 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6716 gfc_array_info
*lss_array
;
6723 gfc_start_block (&block
);
6725 /* Initialize the scalarizer. */
6726 gfc_init_loopinfo (&loop
);
6728 gfc_init_se (&lse
, NULL
);
6729 gfc_init_se (&rse
, NULL
);
6732 rss
= gfc_walk_expr (expr
);
6733 if (rss
== gfc_ss_terminator
)
6734 /* The rhs is scalar. Add a ss for the expression. */
6735 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6737 /* Create a SS for the destination. */
6738 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6740 lss_array
= &lss
->info
->data
.array
;
6741 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6742 lss_array
->descriptor
= dest
;
6743 lss_array
->data
= gfc_conv_array_data (dest
);
6744 lss_array
->offset
= gfc_conv_array_offset (dest
);
6745 for (n
= 0; n
< cm
->as
->rank
; n
++)
6747 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6748 lss_array
->stride
[n
] = gfc_index_one_node
;
6750 mpz_init (lss_array
->shape
[n
]);
6751 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6752 cm
->as
->lower
[n
]->value
.integer
);
6753 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6756 /* Associate the SS with the loop. */
6757 gfc_add_ss_to_loop (&loop
, lss
);
6758 gfc_add_ss_to_loop (&loop
, rss
);
6760 /* Calculate the bounds of the scalarization. */
6761 gfc_conv_ss_startstride (&loop
);
6763 /* Setup the scalarizing loops. */
6764 gfc_conv_loop_setup (&loop
, &expr
->where
);
6766 /* Setup the gfc_se structures. */
6767 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6768 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6771 gfc_mark_ss_chain_used (rss
, 1);
6773 gfc_mark_ss_chain_used (lss
, 1);
6775 /* Start the scalarized loop body. */
6776 gfc_start_scalarized_body (&loop
, &body
);
6778 gfc_conv_tmp_array_ref (&lse
);
6779 if (cm
->ts
.type
== BT_CHARACTER
)
6780 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6782 gfc_conv_expr (&rse
, expr
);
6784 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6785 gfc_add_expr_to_block (&body
, tmp
);
6787 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6789 /* Generate the copying loops. */
6790 gfc_trans_scalarizing_loops (&loop
, &body
);
6792 /* Wrap the whole thing up. */
6793 gfc_add_block_to_block (&block
, &loop
.pre
);
6794 gfc_add_block_to_block (&block
, &loop
.post
);
6796 gcc_assert (lss_array
->shape
!= NULL
);
6797 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6798 gfc_cleanup_loop (&loop
);
6800 return gfc_finish_block (&block
);
6805 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6815 gfc_expr
*arg
= NULL
;
6817 gfc_start_block (&block
);
6818 gfc_init_se (&se
, NULL
);
6820 /* Get the descriptor for the expressions. */
6821 se
.want_pointer
= 0;
6822 gfc_conv_expr_descriptor (&se
, expr
);
6823 gfc_add_block_to_block (&block
, &se
.pre
);
6824 gfc_add_modify (&block
, dest
, se
.expr
);
6826 /* Deal with arrays of derived types with allocatable components. */
6827 if (cm
->ts
.type
== BT_DERIVED
6828 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6829 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6832 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6833 && CLASS_DATA(cm
)->attr
.allocatable
)
6835 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6836 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6841 tmp
= TREE_TYPE (dest
);
6842 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6843 tmp
, expr
->rank
, NULL_TREE
);
6847 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6848 TREE_TYPE(cm
->backend_decl
),
6849 cm
->as
->rank
, NULL_TREE
);
6851 gfc_add_expr_to_block (&block
, tmp
);
6852 gfc_add_block_to_block (&block
, &se
.post
);
6854 if (expr
->expr_type
!= EXPR_VARIABLE
)
6855 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6858 /* We need to know if the argument of a conversion function is a
6859 variable, so that the correct lower bound can be used. */
6860 if (expr
->expr_type
== EXPR_FUNCTION
6861 && expr
->value
.function
.isym
6862 && expr
->value
.function
.isym
->conversion
6863 && expr
->value
.function
.actual
->expr
6864 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6865 arg
= expr
->value
.function
.actual
->expr
;
6867 /* Obtain the array spec of full array references. */
6869 as
= gfc_get_full_arrayspec_from_expr (arg
);
6871 as
= gfc_get_full_arrayspec_from_expr (expr
);
6873 /* Shift the lbound and ubound of temporaries to being unity,
6874 rather than zero, based. Always calculate the offset. */
6875 offset
= gfc_conv_descriptor_offset_get (dest
);
6876 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6877 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6879 for (n
= 0; n
< expr
->rank
; n
++)
6884 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6885 TODO It looks as if gfc_conv_expr_descriptor should return
6886 the correct bounds and that the following should not be
6887 necessary. This would simplify gfc_conv_intrinsic_bound
6889 if (as
&& as
->lower
[n
])
6892 gfc_init_se (&lbse
, NULL
);
6893 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6894 gfc_add_block_to_block (&block
, &lbse
.pre
);
6895 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6899 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6900 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6904 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6907 lbound
= gfc_index_one_node
;
6909 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6911 /* Shift the bounds and set the offset accordingly. */
6912 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6913 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6914 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6915 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6917 gfc_conv_descriptor_ubound_set (&block
, dest
,
6918 gfc_rank_cst
[n
], tmp
);
6919 gfc_conv_descriptor_lbound_set (&block
, dest
,
6920 gfc_rank_cst
[n
], lbound
);
6922 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6923 gfc_conv_descriptor_lbound_get (dest
,
6925 gfc_conv_descriptor_stride_get (dest
,
6927 gfc_add_modify (&block
, tmp2
, tmp
);
6928 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6930 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6935 /* If a conversion expression has a null data pointer
6936 argument, nullify the allocatable component. */
6940 if (arg
->symtree
->n
.sym
->attr
.allocatable
6941 || arg
->symtree
->n
.sym
->attr
.pointer
)
6943 non_null_expr
= gfc_finish_block (&block
);
6944 gfc_start_block (&block
);
6945 gfc_conv_descriptor_data_set (&block
, dest
,
6947 null_expr
= gfc_finish_block (&block
);
6948 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6949 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6950 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6951 return build3_v (COND_EXPR
, tmp
,
6952 null_expr
, non_null_expr
);
6956 return gfc_finish_block (&block
);
6960 /* Allocate or reallocate scalar component, as necessary. */
6963 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6973 tree lhs_cl_size
= NULL_TREE
;
6978 if (!expr2
|| expr2
->rank
)
6981 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6983 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6985 char name
[GFC_MAX_SYMBOL_LEN
+9];
6986 gfc_component
*strlen
;
6987 /* Use the rhs string length and the lhs element size. */
6988 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6989 if (!expr2
->ts
.u
.cl
->backend_decl
)
6991 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6992 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6995 size
= expr2
->ts
.u
.cl
->backend_decl
;
6997 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6999 sprintf (name
, "_%s_length", cm
->name
);
7000 strlen
= gfc_find_component (sym
, name
, true, true);
7001 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
7002 gfc_charlen_type_node
,
7003 TREE_OPERAND (comp
, 0),
7004 strlen
->backend_decl
, NULL_TREE
);
7006 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7007 tmp
= TYPE_SIZE_UNIT (tmp
);
7008 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7009 TREE_TYPE (tmp
), tmp
,
7010 fold_convert (TREE_TYPE (tmp
), size
));
7012 else if (cm
->ts
.type
== BT_CLASS
)
7014 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7015 if (expr2
->ts
.type
== BT_DERIVED
)
7017 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7018 size
= TYPE_SIZE_UNIT (tmp
);
7024 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7025 gfc_add_vptr_component (e2vtab
);
7026 gfc_add_size_component (e2vtab
);
7027 gfc_init_se (&se
, NULL
);
7028 gfc_conv_expr (&se
, e2vtab
);
7029 gfc_add_block_to_block (block
, &se
.pre
);
7030 size
= fold_convert (size_type_node
, se
.expr
);
7031 gfc_free_expr (e2vtab
);
7033 size_in_bytes
= size
;
7037 /* Otherwise use the length in bytes of the rhs. */
7038 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7039 size_in_bytes
= size
;
7042 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7043 size_in_bytes
, size_one_node
);
7045 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7047 tmp
= build_call_expr_loc (input_location
,
7048 builtin_decl_explicit (BUILT_IN_CALLOC
),
7049 2, build_one_cst (size_type_node
),
7051 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7052 gfc_add_modify (block
, comp
, tmp
);
7056 tmp
= build_call_expr_loc (input_location
,
7057 builtin_decl_explicit (BUILT_IN_MALLOC
),
7059 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7060 ptr
= gfc_class_data_get (comp
);
7063 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7064 gfc_add_modify (block
, ptr
, tmp
);
7067 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7068 /* Update the lhs character length. */
7069 gfc_add_modify (block
, lhs_cl_size
, size
);
7073 /* Assign a single component of a derived type constructor. */
7076 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7077 gfc_symbol
*sym
, bool init
)
7085 gfc_start_block (&block
);
7087 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7089 /* Only care about pointers here, not about allocatables. */
7090 gfc_init_se (&se
, NULL
);
7091 /* Pointer component. */
7092 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7093 && !cm
->attr
.proc_pointer
)
7095 /* Array pointer. */
7096 if (expr
->expr_type
== EXPR_NULL
)
7097 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7100 se
.direct_byref
= 1;
7102 gfc_conv_expr_descriptor (&se
, expr
);
7103 gfc_add_block_to_block (&block
, &se
.pre
);
7104 gfc_add_block_to_block (&block
, &se
.post
);
7109 /* Scalar pointers. */
7110 se
.want_pointer
= 1;
7111 gfc_conv_expr (&se
, expr
);
7112 gfc_add_block_to_block (&block
, &se
.pre
);
7114 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7115 && expr
->symtree
->n
.sym
->attr
.dummy
)
7116 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7118 gfc_add_modify (&block
, dest
,
7119 fold_convert (TREE_TYPE (dest
), se
.expr
));
7120 gfc_add_block_to_block (&block
, &se
.post
);
7123 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7125 /* NULL initialization for CLASS components. */
7126 tmp
= gfc_trans_structure_assign (dest
,
7127 gfc_class_initializer (&cm
->ts
, expr
),
7129 gfc_add_expr_to_block (&block
, tmp
);
7131 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7132 && !cm
->attr
.proc_pointer
)
7134 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7135 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7136 else if (cm
->attr
.allocatable
)
7138 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7139 gfc_add_expr_to_block (&block
, tmp
);
7143 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7144 gfc_add_expr_to_block (&block
, tmp
);
7147 else if (cm
->ts
.type
== BT_CLASS
7148 && CLASS_DATA (cm
)->attr
.dimension
7149 && CLASS_DATA (cm
)->attr
.allocatable
7150 && expr
->ts
.type
== BT_DERIVED
)
7152 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7153 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7154 tmp
= gfc_class_vptr_get (dest
);
7155 gfc_add_modify (&block
, tmp
,
7156 fold_convert (TREE_TYPE (tmp
), vtab
));
7157 tmp
= gfc_class_data_get (dest
);
7158 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7159 gfc_add_expr_to_block (&block
, tmp
);
7161 else if (init
&& (cm
->attr
.allocatable
7162 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7163 && expr
->ts
.type
!= BT_CLASS
)))
7165 /* Take care about non-array allocatable components here. The alloc_*
7166 routine below is motivated by the alloc_scalar_allocatable_for_
7167 assignment() routine, but with the realloc portions removed and
7169 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7174 /* The remainder of these instructions follow the if (cm->attr.pointer)
7175 if (!cm->attr.dimension) part above. */
7176 gfc_init_se (&se
, NULL
);
7177 gfc_conv_expr (&se
, expr
);
7178 gfc_add_block_to_block (&block
, &se
.pre
);
7180 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7181 && expr
->symtree
->n
.sym
->attr
.dummy
)
7182 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7184 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7186 tmp
= gfc_class_data_get (dest
);
7187 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7188 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7189 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7190 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7191 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7194 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7196 /* For deferred strings insert a memcpy. */
7197 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7200 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7201 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7203 : expr
->ts
.u
.cl
->backend_decl
);
7204 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7205 gfc_add_expr_to_block (&block
, tmp
);
7208 gfc_add_modify (&block
, tmp
,
7209 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7210 gfc_add_block_to_block (&block
, &se
.post
);
7212 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7214 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7216 tree dealloc
= NULL_TREE
;
7217 gfc_init_se (&se
, NULL
);
7218 gfc_conv_expr (&se
, expr
);
7219 gfc_add_block_to_block (&block
, &se
.pre
);
7220 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7221 expression in a temporary variable and deallocate the allocatable
7222 components. Then we can the copy the expression to the result. */
7223 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7224 && expr
->expr_type
!= EXPR_VARIABLE
)
7226 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7227 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7230 gfc_add_modify (&block
, dest
,
7231 fold_convert (TREE_TYPE (dest
), se
.expr
));
7232 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7233 && expr
->expr_type
!= EXPR_NULL
)
7235 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7237 gfc_add_expr_to_block (&block
, tmp
);
7238 if (dealloc
!= NULL_TREE
)
7239 gfc_add_expr_to_block (&block
, dealloc
);
7241 gfc_add_block_to_block (&block
, &se
.post
);
7245 /* Nested constructors. */
7246 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7247 gfc_add_expr_to_block (&block
, tmp
);
7250 else if (gfc_deferred_strlen (cm
, &tmp
))
7254 gcc_assert (strlen
);
7255 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7257 TREE_OPERAND (dest
, 0),
7260 if (expr
->expr_type
== EXPR_NULL
)
7262 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7263 gfc_add_modify (&block
, dest
, tmp
);
7264 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7265 gfc_add_modify (&block
, strlen
, tmp
);
7270 gfc_init_se (&se
, NULL
);
7271 gfc_conv_expr (&se
, expr
);
7272 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7273 tmp
= build_call_expr_loc (input_location
,
7274 builtin_decl_explicit (BUILT_IN_MALLOC
),
7276 gfc_add_modify (&block
, dest
,
7277 fold_convert (TREE_TYPE (dest
), tmp
));
7278 gfc_add_modify (&block
, strlen
, se
.string_length
);
7279 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7280 gfc_add_expr_to_block (&block
, tmp
);
7283 else if (!cm
->attr
.artificial
)
7285 /* Scalar component (excluding deferred parameters). */
7286 gfc_init_se (&se
, NULL
);
7287 gfc_init_se (&lse
, NULL
);
7289 gfc_conv_expr (&se
, expr
);
7290 if (cm
->ts
.type
== BT_CHARACTER
)
7291 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7293 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7294 gfc_add_expr_to_block (&block
, tmp
);
7296 return gfc_finish_block (&block
);
7299 /* Assign a derived type constructor to a variable. */
7302 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7310 gfc_start_block (&block
);
7311 cm
= expr
->ts
.u
.derived
->components
;
7313 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7314 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7315 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7319 gcc_assert (cm
->backend_decl
== NULL
);
7320 gfc_init_se (&se
, NULL
);
7321 gfc_init_se (&lse
, NULL
);
7322 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7324 gfc_add_modify (&block
, lse
.expr
,
7325 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7327 return gfc_finish_block (&block
);
7330 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7331 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7333 /* Skip absent members in default initializers. */
7334 if (!c
->expr
&& !cm
->attr
.allocatable
)
7337 field
= cm
->backend_decl
;
7338 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7339 dest
, field
, NULL_TREE
);
7342 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7343 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7348 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7349 expr
->ts
.u
.derived
, init
);
7350 gfc_add_expr_to_block (&block
, tmp
);
7352 return gfc_finish_block (&block
);
7355 /* Build an expression for a constructor. If init is nonzero then
7356 this is part of a static variable initializer. */
7359 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7366 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7368 gcc_assert (se
->ss
== NULL
);
7369 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7370 type
= gfc_typenode_for_spec (&expr
->ts
);
7374 /* Create a temporary variable and fill it in. */
7375 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7376 /* The symtree in expr is NULL, if the code to generate is for
7377 initializing the static members only. */
7378 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7379 gfc_add_expr_to_block (&se
->pre
, tmp
);
7383 cm
= expr
->ts
.u
.derived
->components
;
7385 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7386 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7388 /* Skip absent members in default initializers and allocatable
7389 components. Although the latter have a default initializer
7390 of EXPR_NULL,... by default, the static nullify is not needed
7391 since this is done every time we come into scope. */
7392 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7395 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7396 && strcmp (cm
->name
, "_extends") == 0
7397 && cm
->initializer
->symtree
)
7401 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7402 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7403 vtab
= unshare_expr_without_location (vtab
);
7404 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7406 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7408 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7409 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7410 fold_convert (TREE_TYPE (cm
->backend_decl
),
7413 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7414 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7415 fold_convert (TREE_TYPE (cm
->backend_decl
),
7416 integer_zero_node
));
7419 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7420 TREE_TYPE (cm
->backend_decl
),
7421 cm
->attr
.dimension
, cm
->attr
.pointer
,
7422 cm
->attr
.proc_pointer
);
7423 val
= unshare_expr_without_location (val
);
7425 /* Append it to the constructor list. */
7426 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7429 se
->expr
= build_constructor (type
, v
);
7431 TREE_CONSTANT (se
->expr
) = 1;
7435 /* Translate a substring expression. */
7438 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7444 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7446 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7447 expr
->value
.character
.length
,
7448 expr
->value
.character
.string
);
7450 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7451 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7454 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7458 /* Entry point for expression translation. Evaluates a scalar quantity.
7459 EXPR is the expression to be translated, and SE is the state structure if
7460 called from within the scalarized. */
7463 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7468 if (ss
&& ss
->info
->expr
== expr
7469 && (ss
->info
->type
== GFC_SS_SCALAR
7470 || ss
->info
->type
== GFC_SS_REFERENCE
))
7472 gfc_ss_info
*ss_info
;
7475 /* Substitute a scalar expression evaluated outside the scalarization
7477 se
->expr
= ss_info
->data
.scalar
.value
;
7478 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7479 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7481 se
->string_length
= ss_info
->string_length
;
7482 gfc_advance_se_ss_chain (se
);
7486 /* We need to convert the expressions for the iso_c_binding derived types.
7487 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7488 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7489 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7490 updated to be an integer with a kind equal to the size of a (void *). */
7491 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7492 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7494 if (expr
->expr_type
== EXPR_VARIABLE
7495 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7496 || expr
->symtree
->n
.sym
->intmod_sym_id
7497 == ISOCBINDING_NULL_FUNPTR
))
7499 /* Set expr_type to EXPR_NULL, which will result in
7500 null_pointer_node being used below. */
7501 expr
->expr_type
= EXPR_NULL
;
7505 /* Update the type/kind of the expression to be what the new
7506 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7507 expr
->ts
.type
= BT_INTEGER
;
7508 expr
->ts
.f90_type
= BT_VOID
;
7509 expr
->ts
.kind
= gfc_index_integer_kind
;
7513 gfc_fix_class_refs (expr
);
7515 switch (expr
->expr_type
)
7518 gfc_conv_expr_op (se
, expr
);
7522 gfc_conv_function_expr (se
, expr
);
7526 gfc_conv_constant (se
, expr
);
7530 gfc_conv_variable (se
, expr
);
7534 se
->expr
= null_pointer_node
;
7537 case EXPR_SUBSTRING
:
7538 gfc_conv_substring_expr (se
, expr
);
7541 case EXPR_STRUCTURE
:
7542 gfc_conv_structure (se
, expr
, 0);
7546 gfc_conv_array_constructor_expr (se
, expr
);
7555 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7556 of an assignment. */
7558 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7560 gfc_conv_expr (se
, expr
);
7561 /* All numeric lvalues should have empty post chains. If not we need to
7562 figure out a way of rewriting an lvalue so that it has no post chain. */
7563 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7566 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7567 numeric expressions. Used for scalar values where inserting cleanup code
7570 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7574 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7575 gfc_conv_expr (se
, expr
);
7578 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7579 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7581 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7585 /* Helper to translate an expression and convert it to a particular type. */
7587 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7589 gfc_conv_expr_val (se
, expr
);
7590 se
->expr
= convert (type
, se
->expr
);
7594 /* Converts an expression so that it can be passed by reference. Scalar
7598 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7604 if (ss
&& ss
->info
->expr
== expr
7605 && ss
->info
->type
== GFC_SS_REFERENCE
)
7607 /* Returns a reference to the scalar evaluated outside the loop
7609 gfc_conv_expr (se
, expr
);
7611 if (expr
->ts
.type
== BT_CHARACTER
7612 && expr
->expr_type
!= EXPR_FUNCTION
)
7613 gfc_conv_string_parameter (se
);
7615 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7620 if (expr
->ts
.type
== BT_CHARACTER
)
7622 gfc_conv_expr (se
, expr
);
7623 gfc_conv_string_parameter (se
);
7627 if (expr
->expr_type
== EXPR_VARIABLE
)
7629 se
->want_pointer
= 1;
7630 gfc_conv_expr (se
, expr
);
7633 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7634 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7635 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7641 if (expr
->expr_type
== EXPR_FUNCTION
7642 && ((expr
->value
.function
.esym
7643 && expr
->value
.function
.esym
->result
->attr
.pointer
7644 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7645 || (!expr
->value
.function
.esym
&& !expr
->ref
7646 && expr
->symtree
->n
.sym
->attr
.pointer
7647 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7649 se
->want_pointer
= 1;
7650 gfc_conv_expr (se
, expr
);
7651 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7652 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7657 gfc_conv_expr (se
, expr
);
7659 /* Create a temporary var to hold the value. */
7660 if (TREE_CONSTANT (se
->expr
))
7662 tree tmp
= se
->expr
;
7663 STRIP_TYPE_NOPS (tmp
);
7664 var
= build_decl (input_location
,
7665 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7666 DECL_INITIAL (var
) = tmp
;
7667 TREE_STATIC (var
) = 1;
7672 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7673 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7675 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7677 /* Take the address of that value. */
7678 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7683 gfc_trans_pointer_assign (gfc_code
* code
)
7685 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7689 /* Generate code for a pointer assignment. */
7692 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7694 gfc_expr
*expr1_vptr
= NULL
;
7704 gfc_start_block (&block
);
7706 gfc_init_se (&lse
, NULL
);
7708 /* Check whether the expression is a scalar or not; we cannot use
7709 expr1->rank as it can be nonzero for proc pointers. */
7710 ss
= gfc_walk_expr (expr1
);
7711 scalar
= ss
== gfc_ss_terminator
;
7713 gfc_free_ss_chain (ss
);
7715 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7716 && expr2
->expr_type
!= EXPR_FUNCTION
)
7718 gfc_add_data_component (expr2
);
7719 /* The following is required as gfc_add_data_component doesn't
7720 update ts.type if there is a tailing REF_ARRAY. */
7721 expr2
->ts
.type
= BT_DERIVED
;
7726 /* Scalar pointers. */
7727 lse
.want_pointer
= 1;
7728 gfc_conv_expr (&lse
, expr1
);
7729 gfc_init_se (&rse
, NULL
);
7730 rse
.want_pointer
= 1;
7731 gfc_conv_expr (&rse
, expr2
);
7733 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7734 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7735 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7738 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7739 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7740 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7743 gfc_add_block_to_block (&block
, &lse
.pre
);
7744 gfc_add_block_to_block (&block
, &rse
.pre
);
7746 /* For string assignments to unlimited polymorphic pointers add an
7747 assignment of the string_length to the _len component of the
7749 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7750 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7751 && (expr2
->ts
.type
== BT_CHARACTER
||
7752 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7753 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7757 len_comp
= gfc_get_len_component (expr1
);
7758 gfc_init_se (&se
, NULL
);
7759 gfc_conv_expr (&se
, len_comp
);
7761 /* ptr % _len = len (str) */
7762 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7763 lse
.string_length
= se
.expr
;
7764 gfc_free_expr (len_comp
);
7767 /* Check character lengths if character expression. The test is only
7768 really added if -fbounds-check is enabled. Exclude deferred
7769 character length lefthand sides. */
7770 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7771 && !expr1
->ts
.deferred
7772 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7773 && !gfc_is_proc_ptr_comp (expr1
))
7775 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7776 gcc_assert (lse
.string_length
&& rse
.string_length
);
7777 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7778 lse
.string_length
, rse
.string_length
,
7782 /* The assignment to an deferred character length sets the string
7783 length to that of the rhs. */
7784 if (expr1
->ts
.deferred
)
7786 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7787 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7788 else if (lse
.string_length
!= NULL
)
7789 gfc_add_modify (&block
, lse
.string_length
,
7790 build_int_cst (gfc_charlen_type_node
, 0));
7793 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7794 rse
.expr
= gfc_class_data_get (rse
.expr
);
7796 gfc_add_modify (&block
, lse
.expr
,
7797 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7799 gfc_add_block_to_block (&block
, &rse
.post
);
7800 gfc_add_block_to_block (&block
, &lse
.post
);
7807 tree strlen_rhs
= NULL_TREE
;
7809 /* Array pointer. Find the last reference on the LHS and if it is an
7810 array section ref, we're dealing with bounds remapping. In this case,
7811 set it to AR_FULL so that gfc_conv_expr_descriptor does
7812 not see it and process the bounds remapping afterwards explicitly. */
7813 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7814 if (!remap
->next
&& remap
->type
== REF_ARRAY
7815 && remap
->u
.ar
.type
== AR_SECTION
)
7817 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7819 gfc_init_se (&lse
, NULL
);
7821 lse
.descriptor_only
= 1;
7822 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7823 && expr1
->ts
.type
== BT_CLASS
)
7824 expr1_vptr
= gfc_copy_expr (expr1
);
7825 gfc_conv_expr_descriptor (&lse
, expr1
);
7826 strlen_lhs
= lse
.string_length
;
7829 if (expr2
->expr_type
== EXPR_NULL
)
7831 /* Just set the data pointer to null. */
7832 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7834 else if (rank_remap
)
7836 /* If we are rank-remapping, just get the RHS's descriptor and
7837 process this later on. */
7838 gfc_init_se (&rse
, NULL
);
7839 rse
.direct_byref
= 1;
7840 rse
.byref_noassign
= 1;
7842 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7844 gfc_conv_function_expr (&rse
, expr2
);
7846 if (expr1
->ts
.type
!= BT_CLASS
)
7847 rse
.expr
= gfc_class_data_get (rse
.expr
);
7850 gfc_add_block_to_block (&block
, &rse
.pre
);
7851 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7852 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7854 gfc_add_vptr_component (expr1_vptr
);
7855 gfc_init_se (&rse
, NULL
);
7856 rse
.want_pointer
= 1;
7857 gfc_conv_expr (&rse
, expr1_vptr
);
7858 gfc_add_modify (&lse
.pre
, rse
.expr
,
7859 fold_convert (TREE_TYPE (rse
.expr
),
7860 gfc_class_vptr_get (tmp
)));
7861 rse
.expr
= gfc_class_data_get (tmp
);
7864 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7866 tree bound
[GFC_MAX_DIMENSIONS
];
7869 for (i
= 0; i
< expr2
->rank
; i
++)
7870 bound
[i
] = NULL_TREE
;
7871 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7872 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7874 GFC_ARRAY_POINTER_CONT
, false);
7875 tmp
= gfc_create_var (tmp
, "ptrtemp");
7876 lse
.descriptor_only
= 0;
7878 lse
.direct_byref
= 1;
7879 gfc_conv_expr_descriptor (&lse
, expr2
);
7880 strlen_rhs
= lse
.string_length
;
7885 gfc_conv_expr_descriptor (&rse
, expr2
);
7886 strlen_rhs
= rse
.string_length
;
7889 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7891 /* Assign directly to the LHS's descriptor. */
7892 lse
.descriptor_only
= 0;
7893 lse
.direct_byref
= 1;
7894 gfc_conv_expr_descriptor (&lse
, expr2
);
7895 strlen_rhs
= lse
.string_length
;
7897 /* If this is a subreference array pointer assignment, use the rhs
7898 descriptor element size for the lhs span. */
7899 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7901 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7902 gfc_init_se (&rse
, NULL
);
7903 rse
.descriptor_only
= 1;
7904 gfc_conv_expr (&rse
, expr2
);
7905 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7906 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7907 if (!INTEGER_CST_P (tmp
))
7908 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7909 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7912 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7914 gfc_init_se (&rse
, NULL
);
7915 rse
.want_pointer
= 1;
7916 gfc_conv_function_expr (&rse
, expr2
);
7917 if (expr1
->ts
.type
!= BT_CLASS
)
7919 rse
.expr
= gfc_class_data_get (rse
.expr
);
7920 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7924 gfc_add_block_to_block (&block
, &rse
.pre
);
7925 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7926 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7928 gfc_add_vptr_component (expr1_vptr
);
7929 gfc_init_se (&rse
, NULL
);
7930 rse
.want_pointer
= 1;
7931 gfc_conv_expr (&rse
, expr1_vptr
);
7932 gfc_add_modify (&lse
.pre
, rse
.expr
,
7933 fold_convert (TREE_TYPE (rse
.expr
),
7934 gfc_class_vptr_get (tmp
)));
7935 rse
.expr
= gfc_class_data_get (tmp
);
7936 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7941 /* Assign to a temporary descriptor and then copy that
7942 temporary to the pointer. */
7943 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7944 lse
.descriptor_only
= 0;
7946 lse
.direct_byref
= 1;
7947 gfc_conv_expr_descriptor (&lse
, expr2
);
7948 strlen_rhs
= lse
.string_length
;
7949 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7953 gfc_free_expr (expr1_vptr
);
7955 gfc_add_block_to_block (&block
, &lse
.pre
);
7957 gfc_add_block_to_block (&block
, &rse
.pre
);
7959 /* If we do bounds remapping, update LHS descriptor accordingly. */
7963 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7967 /* Do rank remapping. We already have the RHS's descriptor
7968 converted in rse and now have to build the correct LHS
7969 descriptor for it. */
7973 tree lbound
, ubound
;
7976 dtype
= gfc_conv_descriptor_dtype (desc
);
7977 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7978 gfc_add_modify (&block
, dtype
, tmp
);
7980 /* Copy data pointer. */
7981 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7982 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7984 /* Copy offset but adjust it such that it would correspond
7985 to a lbound of zero. */
7986 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7987 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7989 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7991 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7993 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7994 gfc_array_index_type
, stride
, lbound
);
7995 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7996 gfc_array_index_type
, offs
, tmp
);
7998 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8000 /* Set the bounds as declared for the LHS and calculate strides as
8001 well as another offset update accordingly. */
8002 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
8004 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8009 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8011 /* Convert declared bounds. */
8012 gfc_init_se (&lower_se
, NULL
);
8013 gfc_init_se (&upper_se
, NULL
);
8014 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8015 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8017 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8018 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8020 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8021 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8023 lbound
= gfc_evaluate_now (lbound
, &block
);
8024 ubound
= gfc_evaluate_now (ubound
, &block
);
8026 gfc_add_block_to_block (&block
, &lower_se
.post
);
8027 gfc_add_block_to_block (&block
, &upper_se
.post
);
8029 /* Set bounds in descriptor. */
8030 gfc_conv_descriptor_lbound_set (&block
, desc
,
8031 gfc_rank_cst
[dim
], lbound
);
8032 gfc_conv_descriptor_ubound_set (&block
, desc
,
8033 gfc_rank_cst
[dim
], ubound
);
8036 stride
= gfc_evaluate_now (stride
, &block
);
8037 gfc_conv_descriptor_stride_set (&block
, desc
,
8038 gfc_rank_cst
[dim
], stride
);
8040 /* Update offset. */
8041 offs
= gfc_conv_descriptor_offset_get (desc
);
8042 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8043 gfc_array_index_type
, lbound
, stride
);
8044 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8045 gfc_array_index_type
, offs
, tmp
);
8046 offs
= gfc_evaluate_now (offs
, &block
);
8047 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8049 /* Update stride. */
8050 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8051 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8052 gfc_array_index_type
, stride
, tmp
);
8057 /* Bounds remapping. Just shift the lower bounds. */
8059 gcc_assert (expr1
->rank
== expr2
->rank
);
8061 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8065 gcc_assert (remap
->u
.ar
.start
[dim
]);
8066 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8067 gfc_init_se (&lbound_se
, NULL
);
8068 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8070 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8071 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8072 dim
, lbound_se
.expr
);
8073 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8078 /* Check string lengths if applicable. The check is only really added
8079 to the output code if -fbounds-check is enabled. */
8080 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8082 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8083 gcc_assert (strlen_lhs
&& strlen_rhs
);
8084 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8085 strlen_lhs
, strlen_rhs
, &block
);
8088 /* If rank remapping was done, check with -fcheck=bounds that
8089 the target is at least as large as the pointer. */
8090 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8096 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8097 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8099 lsize
= gfc_evaluate_now (lsize
, &block
);
8100 rsize
= gfc_evaluate_now (rsize
, &block
);
8101 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8104 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8105 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8109 gfc_add_block_to_block (&block
, &lse
.post
);
8111 gfc_add_block_to_block (&block
, &rse
.post
);
8114 return gfc_finish_block (&block
);
8118 /* Makes sure se is suitable for passing as a function string parameter. */
8119 /* TODO: Need to check all callers of this function. It may be abused. */
8122 gfc_conv_string_parameter (gfc_se
* se
)
8126 if (TREE_CODE (se
->expr
) == STRING_CST
)
8128 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8129 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8133 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8135 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8137 type
= TREE_TYPE (se
->expr
);
8138 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8142 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8144 type
= build_pointer_type (type
);
8145 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8149 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8153 /* Generate code for assignment of scalar variables. Includes character
8154 strings and derived types with allocatable components.
8155 If you know that the LHS has no allocations, set dealloc to false.
8157 DEEP_COPY has no effect if the typespec TS is not a derived type with
8158 allocatable components. Otherwise, if it is set, an explicit copy of each
8159 allocatable component is made. This is necessary as a simple copy of the
8160 whole object would copy array descriptors as is, so that the lhs's
8161 allocatable components would point to the rhs's after the assignment.
8162 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8163 necessary if the rhs is a non-pointer function, as the allocatable components
8164 are not accessible by other means than the function's result after the
8165 function has returned. It is even more subtle when temporaries are involved,
8166 as the two following examples show:
8167 1. When we evaluate an array constructor, a temporary is created. Thus
8168 there is theoretically no alias possible. However, no deep copy is
8169 made for this temporary, so that if the constructor is made of one or
8170 more variable with allocatable components, those components still point
8171 to the variable's: DEEP_COPY should be set for the assignment from the
8172 temporary to the lhs in that case.
8173 2. When assigning a scalar to an array, we evaluate the scalar value out
8174 of the loop, store it into a temporary variable, and assign from that.
8175 In that case, deep copying when assigning to the temporary would be a
8176 waste of resources; however deep copies should happen when assigning from
8177 the temporary to each array element: again DEEP_COPY should be set for
8178 the assignment from the temporary to the lhs. */
8181 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8182 bool deep_copy
, bool dealloc
)
8188 gfc_init_block (&block
);
8190 if (ts
.type
== BT_CHARACTER
)
8195 if (lse
->string_length
!= NULL_TREE
)
8197 gfc_conv_string_parameter (lse
);
8198 gfc_add_block_to_block (&block
, &lse
->pre
);
8199 llen
= lse
->string_length
;
8202 if (rse
->string_length
!= NULL_TREE
)
8204 gcc_assert (rse
->string_length
!= NULL_TREE
);
8205 gfc_conv_string_parameter (rse
);
8206 gfc_add_block_to_block (&block
, &rse
->pre
);
8207 rlen
= rse
->string_length
;
8210 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8211 rse
->expr
, ts
.kind
);
8213 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8215 tree tmp_var
= NULL_TREE
;
8218 /* Are the rhs and the lhs the same? */
8221 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8222 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8223 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8224 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8227 /* Deallocate the lhs allocated components as long as it is not
8228 the same as the rhs. This must be done following the assignment
8229 to prevent deallocating data that could be used in the rhs
8233 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8234 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8236 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8238 gfc_add_expr_to_block (&lse
->post
, tmp
);
8241 gfc_add_block_to_block (&block
, &rse
->pre
);
8242 gfc_add_block_to_block (&block
, &lse
->pre
);
8244 gfc_add_modify (&block
, lse
->expr
,
8245 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8247 /* Restore pointer address of coarray components. */
8248 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8250 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8251 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8253 gfc_add_expr_to_block (&block
, tmp
);
8256 /* Do a deep copy if the rhs is a variable, if it is not the
8260 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8261 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8263 gfc_add_expr_to_block (&block
, tmp
);
8266 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8268 gfc_add_block_to_block (&block
, &lse
->pre
);
8269 gfc_add_block_to_block (&block
, &rse
->pre
);
8270 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8271 TREE_TYPE (lse
->expr
), rse
->expr
);
8272 gfc_add_modify (&block
, lse
->expr
, tmp
);
8276 gfc_add_block_to_block (&block
, &lse
->pre
);
8277 gfc_add_block_to_block (&block
, &rse
->pre
);
8279 gfc_add_modify (&block
, lse
->expr
,
8280 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8283 gfc_add_block_to_block (&block
, &lse
->post
);
8284 gfc_add_block_to_block (&block
, &rse
->post
);
8286 return gfc_finish_block (&block
);
8290 /* There are quite a lot of restrictions on the optimisation in using an
8291 array function assign without a temporary. */
8294 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8297 bool seen_array_ref
;
8299 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8301 /* Play it safe with class functions assigned to a derived type. */
8302 if (gfc_is_alloc_class_array_function (expr2
)
8303 && expr1
->ts
.type
== BT_DERIVED
)
8306 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8307 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8310 /* Elemental functions are scalarized so that they don't need a
8311 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8312 they would need special treatment in gfc_trans_arrayfunc_assign. */
8313 if (expr2
->value
.function
.esym
!= NULL
8314 && expr2
->value
.function
.esym
->attr
.elemental
)
8317 /* Need a temporary if rhs is not FULL or a contiguous section. */
8318 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8321 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8322 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8325 /* Functions returning pointers or allocatables need temporaries. */
8326 c
= expr2
->value
.function
.esym
8327 ? (expr2
->value
.function
.esym
->attr
.pointer
8328 || expr2
->value
.function
.esym
->attr
.allocatable
)
8329 : (expr2
->symtree
->n
.sym
->attr
.pointer
8330 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8334 /* Character array functions need temporaries unless the
8335 character lengths are the same. */
8336 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8338 if (expr1
->ts
.u
.cl
->length
== NULL
8339 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8342 if (expr2
->ts
.u
.cl
->length
== NULL
8343 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8346 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8347 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8351 /* Check that no LHS component references appear during an array
8352 reference. This is needed because we do not have the means to
8353 span any arbitrary stride with an array descriptor. This check
8354 is not needed for the rhs because the function result has to be
8356 seen_array_ref
= false;
8357 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8359 if (ref
->type
== REF_ARRAY
)
8360 seen_array_ref
= true;
8361 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8365 /* Check for a dependency. */
8366 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8367 expr2
->value
.function
.esym
,
8368 expr2
->value
.function
.actual
,
8372 /* If we have reached here with an intrinsic function, we do not
8373 need a temporary except in the particular case that reallocation
8374 on assignment is active and the lhs is allocatable and a target. */
8375 if (expr2
->value
.function
.isym
)
8376 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8378 /* If the LHS is a dummy, we need a temporary if it is not
8380 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8383 /* If the lhs has been host_associated, is in common, a pointer or is
8384 a target and the function is not using a RESULT variable, aliasing
8385 can occur and a temporary is needed. */
8386 if ((sym
->attr
.host_assoc
8387 || sym
->attr
.in_common
8388 || sym
->attr
.pointer
8389 || sym
->attr
.cray_pointee
8390 || sym
->attr
.target
)
8391 && expr2
->symtree
!= NULL
8392 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8395 /* A PURE function can unconditionally be called without a temporary. */
8396 if (expr2
->value
.function
.esym
!= NULL
8397 && expr2
->value
.function
.esym
->attr
.pure
)
8400 /* Implicit_pure functions are those which could legally be declared
8402 if (expr2
->value
.function
.esym
!= NULL
8403 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8406 if (!sym
->attr
.use_assoc
8407 && !sym
->attr
.in_common
8408 && !sym
->attr
.pointer
8409 && !sym
->attr
.target
8410 && !sym
->attr
.cray_pointee
8411 && expr2
->value
.function
.esym
)
8413 /* A temporary is not needed if the function is not contained and
8414 the variable is local or host associated and not a pointer or
8416 if (!expr2
->value
.function
.esym
->attr
.contained
)
8419 /* A temporary is not needed if the lhs has never been host
8420 associated and the procedure is contained. */
8421 else if (!sym
->attr
.host_assoc
)
8424 /* A temporary is not needed if the variable is local and not
8425 a pointer, a target or a result. */
8427 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8431 /* Default to temporary use. */
8436 /* Provide the loop info so that the lhs descriptor can be built for
8437 reallocatable assignments from extrinsic function calls. */
8440 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8443 /* Signal that the function call should not be made by
8444 gfc_conv_loop_setup. */
8445 se
->ss
->is_alloc_lhs
= 1;
8446 gfc_init_loopinfo (loop
);
8447 gfc_add_ss_to_loop (loop
, *ss
);
8448 gfc_add_ss_to_loop (loop
, se
->ss
);
8449 gfc_conv_ss_startstride (loop
);
8450 gfc_conv_loop_setup (loop
, where
);
8451 gfc_copy_loopinfo_to_se (se
, loop
);
8452 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8453 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8454 se
->ss
->is_alloc_lhs
= 0;
8458 /* For assignment to a reallocatable lhs from intrinsic functions,
8459 replace the se.expr (ie. the result) with a temporary descriptor.
8460 Null the data field so that the library allocates space for the
8461 result. Free the data of the original descriptor after the function,
8462 in case it appears in an argument expression and transfer the
8463 result to the original descriptor. */
8466 fcncall_realloc_result (gfc_se
*se
, int rank
)
8475 /* Use the allocation done by the library. Substitute the lhs
8476 descriptor with a copy, whose data field is nulled.*/
8477 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8478 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8479 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8481 /* Unallocated, the descriptor does not have a dtype. */
8482 tmp
= gfc_conv_descriptor_dtype (desc
);
8483 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8485 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8486 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8487 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8489 /* Free the lhs after the function call and copy the result data to
8490 the lhs descriptor. */
8491 tmp
= gfc_conv_descriptor_data_get (desc
);
8492 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8493 boolean_type_node
, tmp
,
8494 build_int_cst (TREE_TYPE (tmp
), 0));
8495 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8496 tmp
= gfc_call_free (tmp
);
8497 gfc_add_expr_to_block (&se
->post
, tmp
);
8499 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8500 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8502 /* Check that the shapes are the same between lhs and expression. */
8503 for (n
= 0 ; n
< rank
; n
++)
8506 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8507 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8508 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8509 gfc_array_index_type
, tmp
, tmp1
);
8510 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8511 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8512 gfc_array_index_type
, tmp
, tmp1
);
8513 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8514 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8515 gfc_array_index_type
, tmp
, tmp1
);
8516 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8517 boolean_type_node
, tmp
,
8518 gfc_index_zero_node
);
8519 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8520 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8521 boolean_type_node
, tmp
,
8525 /* 'zero_cond' being true is equal to lhs not being allocated or the
8526 shapes being different. */
8527 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8529 /* Now reset the bounds returned from the function call to bounds based
8530 on the lhs lbounds, except where the lhs is not allocated or the shapes
8531 of 'variable and 'expr' are different. Set the offset accordingly. */
8532 offset
= gfc_index_zero_node
;
8533 for (n
= 0 ; n
< rank
; n
++)
8537 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8538 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8539 gfc_array_index_type
, zero_cond
,
8540 gfc_index_one_node
, lbound
);
8541 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8543 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8544 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8545 gfc_array_index_type
, tmp
, lbound
);
8546 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8547 gfc_rank_cst
[n
], lbound
);
8548 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8549 gfc_rank_cst
[n
], tmp
);
8551 /* Set stride and accumulate the offset. */
8552 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8553 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8554 gfc_rank_cst
[n
], tmp
);
8555 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8556 gfc_array_index_type
, lbound
, tmp
);
8557 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8558 gfc_array_index_type
, offset
, tmp
);
8559 offset
= gfc_evaluate_now (offset
, &se
->post
);
8562 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8567 /* Try to translate array(:) = func (...), where func is a transformational
8568 array function, without using a temporary. Returns NULL if this isn't the
8572 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8576 gfc_component
*comp
= NULL
;
8579 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8582 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8584 comp
= gfc_get_proc_ptr_comp (expr2
);
8585 gcc_assert (expr2
->value
.function
.isym
8586 || (comp
&& comp
->attr
.dimension
)
8587 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8588 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8590 gfc_init_se (&se
, NULL
);
8591 gfc_start_block (&se
.pre
);
8592 se
.want_pointer
= 1;
8594 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8596 if (expr1
->ts
.type
== BT_DERIVED
8597 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8600 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8602 gfc_add_expr_to_block (&se
.pre
, tmp
);
8605 se
.direct_byref
= 1;
8606 se
.ss
= gfc_walk_expr (expr2
);
8607 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8609 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8610 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8611 Clearly, this cannot be done for an allocatable function result, since
8612 the shape of the result is unknown and, in any case, the function must
8613 correctly take care of the reallocation internally. For intrinsic
8614 calls, the array data is freed and the library takes care of allocation.
8615 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8617 if (flag_realloc_lhs
8618 && gfc_is_reallocatable_lhs (expr1
)
8619 && !gfc_expr_attr (expr1
).codimension
8620 && !gfc_is_coindexed (expr1
)
8621 && !(expr2
->value
.function
.esym
8622 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8624 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8626 if (!expr2
->value
.function
.isym
)
8628 ss
= gfc_walk_expr (expr1
);
8629 gcc_assert (ss
!= gfc_ss_terminator
);
8631 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8632 ss
->is_alloc_lhs
= 1;
8635 fcncall_realloc_result (&se
, expr1
->rank
);
8638 gfc_conv_function_expr (&se
, expr2
);
8639 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8642 gfc_cleanup_loop (&loop
);
8644 gfc_free_ss_chain (se
.ss
);
8646 return gfc_finish_block (&se
.pre
);
8650 /* Try to efficiently translate array(:) = 0. Return NULL if this
8654 gfc_trans_zero_assign (gfc_expr
* expr
)
8656 tree dest
, len
, type
;
8660 sym
= expr
->symtree
->n
.sym
;
8661 dest
= gfc_get_symbol_decl (sym
);
8663 type
= TREE_TYPE (dest
);
8664 if (POINTER_TYPE_P (type
))
8665 type
= TREE_TYPE (type
);
8666 if (!GFC_ARRAY_TYPE_P (type
))
8669 /* Determine the length of the array. */
8670 len
= GFC_TYPE_ARRAY_SIZE (type
);
8671 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8674 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8675 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8676 fold_convert (gfc_array_index_type
, tmp
));
8678 /* If we are zeroing a local array avoid taking its address by emitting
8680 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8681 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8682 dest
, build_constructor (TREE_TYPE (dest
),
8685 /* Convert arguments to the correct types. */
8686 dest
= fold_convert (pvoid_type_node
, dest
);
8687 len
= fold_convert (size_type_node
, len
);
8689 /* Construct call to __builtin_memset. */
8690 tmp
= build_call_expr_loc (input_location
,
8691 builtin_decl_explicit (BUILT_IN_MEMSET
),
8692 3, dest
, integer_zero_node
, len
);
8693 return fold_convert (void_type_node
, tmp
);
8697 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8698 that constructs the call to __builtin_memcpy. */
8701 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8705 /* Convert arguments to the correct types. */
8706 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8707 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8709 dst
= fold_convert (pvoid_type_node
, dst
);
8711 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8712 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8714 src
= fold_convert (pvoid_type_node
, src
);
8716 len
= fold_convert (size_type_node
, len
);
8718 /* Construct call to __builtin_memcpy. */
8719 tmp
= build_call_expr_loc (input_location
,
8720 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8722 return fold_convert (void_type_node
, tmp
);
8726 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8727 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8728 source/rhs, both are gfc_full_array_ref_p which have been checked for
8732 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8734 tree dst
, dlen
, dtype
;
8735 tree src
, slen
, stype
;
8738 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8739 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8741 dtype
= TREE_TYPE (dst
);
8742 if (POINTER_TYPE_P (dtype
))
8743 dtype
= TREE_TYPE (dtype
);
8744 stype
= TREE_TYPE (src
);
8745 if (POINTER_TYPE_P (stype
))
8746 stype
= TREE_TYPE (stype
);
8748 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8751 /* Determine the lengths of the arrays. */
8752 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8753 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8755 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8756 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8757 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8759 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8760 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8762 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8763 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8764 slen
, fold_convert (gfc_array_index_type
, tmp
));
8766 /* Sanity check that they are the same. This should always be
8767 the case, as we should already have checked for conformance. */
8768 if (!tree_int_cst_equal (slen
, dlen
))
8771 return gfc_build_memcpy_call (dst
, src
, dlen
);
8775 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8776 this can't be done. EXPR1 is the destination/lhs for which
8777 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8780 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8782 unsigned HOST_WIDE_INT nelem
;
8788 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8792 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8793 dtype
= TREE_TYPE (dst
);
8794 if (POINTER_TYPE_P (dtype
))
8795 dtype
= TREE_TYPE (dtype
);
8796 if (!GFC_ARRAY_TYPE_P (dtype
))
8799 /* Determine the lengths of the array. */
8800 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8801 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8804 /* Confirm that the constructor is the same size. */
8805 if (compare_tree_int (len
, nelem
) != 0)
8808 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8809 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8810 fold_convert (gfc_array_index_type
, tmp
));
8812 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8813 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8815 stype
= TREE_TYPE (src
);
8816 if (POINTER_TYPE_P (stype
))
8817 stype
= TREE_TYPE (stype
);
8819 return gfc_build_memcpy_call (dst
, src
, len
);
8823 /* Tells whether the expression is to be treated as a variable reference. */
8826 expr_is_variable (gfc_expr
*expr
)
8829 gfc_component
*comp
;
8830 gfc_symbol
*func_ifc
;
8832 if (expr
->expr_type
== EXPR_VARIABLE
)
8835 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8838 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8839 return expr_is_variable (arg
);
8842 /* A data-pointer-returning function should be considered as a variable
8844 if (expr
->expr_type
== EXPR_FUNCTION
8845 && expr
->ref
== NULL
)
8847 if (expr
->value
.function
.isym
!= NULL
)
8850 if (expr
->value
.function
.esym
!= NULL
)
8852 func_ifc
= expr
->value
.function
.esym
;
8857 gcc_assert (expr
->symtree
);
8858 func_ifc
= expr
->symtree
->n
.sym
;
8865 comp
= gfc_get_proc_ptr_comp (expr
);
8866 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8869 func_ifc
= comp
->ts
.interface
;
8873 if (expr
->expr_type
== EXPR_COMPCALL
)
8875 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8876 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8883 gcc_assert (func_ifc
->attr
.function
8884 && func_ifc
->result
!= NULL
);
8885 return func_ifc
->result
->attr
.pointer
;
8889 /* Is the lhs OK for automatic reallocation? */
8892 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8896 /* An allocatable variable with no reference. */
8897 if (expr
->symtree
->n
.sym
->attr
.allocatable
8901 /* All that can be left are allocatable components. */
8902 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8903 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8904 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8907 /* Find an allocatable component ref last. */
8908 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8909 if (ref
->type
== REF_COMPONENT
8911 && ref
->u
.c
.component
->attr
.allocatable
)
8918 /* Allocate or reallocate scalar lhs, as necessary. */
8921 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8936 if (!expr1
|| expr1
->rank
)
8939 if (!expr2
|| expr2
->rank
)
8942 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8943 if (ref
->type
== REF_SUBSTRING
)
8946 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8948 /* Since this is a scalar lhs, we can afford to do this. That is,
8949 there is no risk of side effects being repeated. */
8950 gfc_init_se (&lse
, NULL
);
8951 lse
.want_pointer
= 1;
8952 gfc_conv_expr (&lse
, expr1
);
8954 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8955 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8957 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8958 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8959 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8961 tmp
= build3_v (COND_EXPR
, cond
,
8962 build1_v (GOTO_EXPR
, jump_label1
),
8963 build_empty_stmt (input_location
));
8964 gfc_add_expr_to_block (block
, tmp
);
8966 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8968 /* Use the rhs string length and the lhs element size. */
8969 size
= string_length
;
8970 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8971 tmp
= TYPE_SIZE_UNIT (tmp
);
8972 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8973 TREE_TYPE (tmp
), tmp
,
8974 fold_convert (TREE_TYPE (tmp
), size
));
8978 /* Otherwise use the length in bytes of the rhs. */
8979 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8980 size_in_bytes
= size
;
8983 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8984 size_in_bytes
, size_one_node
);
8986 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8988 tmp
= build_call_expr_loc (input_location
,
8989 builtin_decl_explicit (BUILT_IN_CALLOC
),
8990 2, build_one_cst (size_type_node
),
8992 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8993 gfc_add_modify (block
, lse
.expr
, tmp
);
8997 tmp
= build_call_expr_loc (input_location
,
8998 builtin_decl_explicit (BUILT_IN_MALLOC
),
9000 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9001 gfc_add_modify (block
, lse
.expr
, tmp
);
9004 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9006 /* Deferred characters need checking for lhs and rhs string
9007 length. Other deferred parameter variables will have to
9009 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9010 gfc_add_expr_to_block (block
, tmp
);
9012 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9013 gfc_add_expr_to_block (block
, tmp
);
9015 /* For a deferred length character, reallocate if lengths of lhs and
9016 rhs are different. */
9017 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9019 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9020 lse
.string_length
, size
);
9021 /* Jump past the realloc if the lengths are the same. */
9022 tmp
= build3_v (COND_EXPR
, cond
,
9023 build1_v (GOTO_EXPR
, jump_label2
),
9024 build_empty_stmt (input_location
));
9025 gfc_add_expr_to_block (block
, tmp
);
9026 tmp
= build_call_expr_loc (input_location
,
9027 builtin_decl_explicit (BUILT_IN_REALLOC
),
9028 2, fold_convert (pvoid_type_node
, lse
.expr
),
9030 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9031 gfc_add_modify (block
, lse
.expr
, tmp
);
9032 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9033 gfc_add_expr_to_block (block
, tmp
);
9035 /* Update the lhs character length. */
9036 size
= string_length
;
9037 gfc_add_modify (block
, lse
.string_length
, size
);
9041 /* Check for assignments of the type
9045 to make sure we do not check for reallocation unneccessarily. */
9049 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9051 gfc_actual_arglist
*a
;
9054 switch (expr2
->expr_type
)
9057 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9060 if (expr2
->value
.function
.esym
9061 && expr2
->value
.function
.esym
->attr
.elemental
)
9063 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9066 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9071 else if (expr2
->value
.function
.isym
9072 && expr2
->value
.function
.isym
->elemental
)
9074 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9077 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9086 switch (expr2
->value
.op
.op
)
9089 case INTRINSIC_UPLUS
:
9090 case INTRINSIC_UMINUS
:
9091 case INTRINSIC_PARENTHESES
:
9092 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9094 case INTRINSIC_PLUS
:
9095 case INTRINSIC_MINUS
:
9096 case INTRINSIC_TIMES
:
9097 case INTRINSIC_DIVIDE
:
9098 case INTRINSIC_POWER
:
9102 case INTRINSIC_NEQV
:
9109 case INTRINSIC_EQ_OS
:
9110 case INTRINSIC_NE_OS
:
9111 case INTRINSIC_GT_OS
:
9112 case INTRINSIC_GE_OS
:
9113 case INTRINSIC_LT_OS
:
9114 case INTRINSIC_LE_OS
:
9116 e1
= expr2
->value
.op
.op1
;
9117 e2
= expr2
->value
.op
.op2
;
9119 if (e1
->rank
== 0 && e2
->rank
> 0)
9120 return is_runtime_conformable (expr1
, e2
);
9121 else if (e1
->rank
> 0 && e2
->rank
== 0)
9122 return is_runtime_conformable (expr1
, e1
);
9123 else if (e1
->rank
> 0 && e2
->rank
> 0)
9124 return is_runtime_conformable (expr1
, e1
)
9125 && is_runtime_conformable (expr1
, e2
);
9141 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9142 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9143 init_flag indicates initialization expressions and dealloc that no
9144 deallocate prior assignment is needed (if in doubt, set true). */
9147 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9153 gfc_ss
*lss_section
;
9160 bool scalar_to_array
;
9164 /* Assignment of the form lhs = rhs. */
9165 gfc_start_block (&block
);
9167 gfc_init_se (&lse
, NULL
);
9168 gfc_init_se (&rse
, NULL
);
9171 lss
= gfc_walk_expr (expr1
);
9172 if (gfc_is_reallocatable_lhs (expr1
)
9173 && !(expr2
->expr_type
== EXPR_FUNCTION
9174 && expr2
->value
.function
.isym
!= NULL
))
9175 lss
->is_alloc_lhs
= 1;
9178 if ((expr1
->ts
.type
== BT_DERIVED
)
9179 && (gfc_is_alloc_class_array_function (expr2
)
9180 || gfc_is_alloc_class_scalar_function (expr2
)))
9181 expr2
->must_finalize
= 1;
9183 if (lss
!= gfc_ss_terminator
)
9185 /* The assignment needs scalarization. */
9188 /* Find a non-scalar SS from the lhs. */
9189 while (lss_section
!= gfc_ss_terminator
9190 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9191 lss_section
= lss_section
->next
;
9193 gcc_assert (lss_section
!= gfc_ss_terminator
);
9195 /* Initialize the scalarizer. */
9196 gfc_init_loopinfo (&loop
);
9199 rss
= gfc_walk_expr (expr2
);
9200 if (rss
== gfc_ss_terminator
)
9201 /* The rhs is scalar. Add a ss for the expression. */
9202 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9204 /* Associate the SS with the loop. */
9205 gfc_add_ss_to_loop (&loop
, lss
);
9206 gfc_add_ss_to_loop (&loop
, rss
);
9208 /* Calculate the bounds of the scalarization. */
9209 gfc_conv_ss_startstride (&loop
);
9210 /* Enable loop reversal. */
9211 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9212 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9213 /* Resolve any data dependencies in the statement. */
9214 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9215 /* Setup the scalarizing loops. */
9216 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9218 /* Setup the gfc_se structures. */
9219 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9220 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9223 gfc_mark_ss_chain_used (rss
, 1);
9224 if (loop
.temp_ss
== NULL
)
9227 gfc_mark_ss_chain_used (lss
, 1);
9231 lse
.ss
= loop
.temp_ss
;
9232 gfc_mark_ss_chain_used (lss
, 3);
9233 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9236 /* Allow the scalarizer to workshare array assignments. */
9237 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9238 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9240 /* Start the scalarized loop body. */
9241 gfc_start_scalarized_body (&loop
, &body
);
9244 gfc_init_block (&body
);
9246 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9248 /* Translate the expression. */
9249 gfc_conv_expr (&rse
, expr2
);
9251 /* Deal with the case of a scalar class function assigned to a derived type. */
9252 if (gfc_is_alloc_class_scalar_function (expr2
)
9253 && expr1
->ts
.type
== BT_DERIVED
)
9255 rse
.expr
= gfc_class_data_get (rse
.expr
);
9256 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9259 /* Stabilize a string length for temporaries. */
9260 if (expr2
->ts
.type
== BT_CHARACTER
&& !expr2
->ts
.deferred
)
9261 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9262 else if (expr2
->ts
.type
== BT_CHARACTER
)
9263 string_length
= rse
.string_length
;
9265 string_length
= NULL_TREE
;
9269 gfc_conv_tmp_array_ref (&lse
);
9270 if (expr2
->ts
.type
== BT_CHARACTER
)
9271 lse
.string_length
= string_length
;
9274 gfc_conv_expr (&lse
, expr1
);
9276 /* Assignments of scalar derived types with allocatable components
9277 to arrays must be done with a deep copy and the rhs temporary
9278 must have its components deallocated afterwards. */
9279 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9280 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9281 && !expr_is_variable (expr2
)
9282 && expr1
->rank
&& !expr2
->rank
);
9283 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9285 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9286 && gfc_is_alloc_class_scalar_function (expr2
));
9287 if (scalar_to_array
&& dealloc
)
9289 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9290 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9293 /* When assigning a character function result to a deferred-length variable,
9294 the function call must happen before the (re)allocation of the lhs -
9295 otherwise the character length of the result is not known.
9296 NOTE: This relies on having the exact dependence of the length type
9297 parameter available to the caller; gfortran saves it in the .mod files.
9298 NOTE ALSO: The concatenation operation generates a temporary pointer,
9299 whose allocation must go to the innermost loop. */
9300 if (flag_realloc_lhs
9301 && expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
9302 && !(lss
!= gfc_ss_terminator
9303 && expr2
->expr_type
== EXPR_OP
9304 && expr2
->value
.op
.op
== INTRINSIC_CONCAT
))
9305 gfc_add_block_to_block (&block
, &rse
.pre
);
9307 /* Nullify the allocatable components corresponding to those of the lhs
9308 derived type, so that the finalization of the function result does not
9309 affect the lhs of the assignment. Prepend is used to ensure that the
9310 nullification occurs before the call to the finalizer. In the case of
9311 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9312 as part of the deep copy. */
9313 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9314 && (gfc_is_alloc_class_array_function (expr2
)
9315 || gfc_is_alloc_class_scalar_function (expr2
)))
9318 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9319 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9320 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9321 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9324 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9325 expr_is_variable (expr2
) || scalar_to_array
9326 || expr2
->expr_type
== EXPR_ARRAY
,
9327 !(l_is_temp
|| init_flag
) && dealloc
);
9328 gfc_add_expr_to_block (&body
, tmp
);
9330 if (lss
== gfc_ss_terminator
)
9332 /* F2003: Add the code for reallocation on assignment. */
9333 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9334 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9337 /* Use the scalar assignment as is. */
9338 gfc_add_block_to_block (&block
, &body
);
9342 gcc_assert (lse
.ss
== gfc_ss_terminator
9343 && rse
.ss
== gfc_ss_terminator
);
9347 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9349 /* We need to copy the temporary to the actual lhs. */
9350 gfc_init_se (&lse
, NULL
);
9351 gfc_init_se (&rse
, NULL
);
9352 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9353 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9355 rse
.ss
= loop
.temp_ss
;
9358 gfc_conv_tmp_array_ref (&rse
);
9359 gfc_conv_expr (&lse
, expr1
);
9361 gcc_assert (lse
.ss
== gfc_ss_terminator
9362 && rse
.ss
== gfc_ss_terminator
);
9364 if (expr2
->ts
.type
== BT_CHARACTER
)
9365 rse
.string_length
= string_length
;
9367 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9369 gfc_add_expr_to_block (&body
, tmp
);
9372 /* F2003: Allocate or reallocate lhs of allocatable array. */
9373 if (flag_realloc_lhs
9374 && gfc_is_reallocatable_lhs (expr1
)
9375 && !gfc_expr_attr (expr1
).codimension
9376 && !gfc_is_coindexed (expr1
)
9378 && !is_runtime_conformable (expr1
, expr2
))
9380 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9381 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9382 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9383 if (tmp
!= NULL_TREE
)
9384 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9387 /* Generate the copying loops. */
9388 gfc_trans_scalarizing_loops (&loop
, &body
);
9390 /* Wrap the whole thing up. */
9391 gfc_add_block_to_block (&block
, &loop
.pre
);
9392 gfc_add_block_to_block (&block
, &loop
.post
);
9394 gfc_cleanup_loop (&loop
);
9397 return gfc_finish_block (&block
);
9401 /* Check whether EXPR is a copyable array. */
9404 copyable_array_p (gfc_expr
* expr
)
9406 if (expr
->expr_type
!= EXPR_VARIABLE
)
9409 /* First check it's an array. */
9410 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9413 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9416 /* Next check that it's of a simple enough type. */
9417 switch (expr
->ts
.type
)
9429 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9438 /* Translate an assignment. */
9441 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9446 /* Special case a single function returning an array. */
9447 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9449 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9454 /* Special case assigning an array to zero. */
9455 if (copyable_array_p (expr1
)
9456 && is_zero_initializer_p (expr2
))
9458 tmp
= gfc_trans_zero_assign (expr1
);
9463 /* Special case copying one array to another. */
9464 if (copyable_array_p (expr1
)
9465 && copyable_array_p (expr2
)
9466 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9467 && !gfc_check_dependency (expr1
, expr2
, 0))
9469 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9474 /* Special case initializing an array from a constant array constructor. */
9475 if (copyable_array_p (expr1
)
9476 && expr2
->expr_type
== EXPR_ARRAY
9477 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9479 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9484 /* Fallback to the scalarizer to generate explicit loops. */
9485 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9489 gfc_trans_init_assign (gfc_code
* code
)
9491 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9495 gfc_trans_assign (gfc_code
* code
)
9497 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);