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"
32 #include "fold-const.h"
33 #include "stringpool.h"
34 #include "diagnostic-core.h" /* For fatal_error. */
35 #include "langhooks.h"
38 #include "constructor.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
45 #include "dependency.h"
48 /* Convert a scalar to an array descriptor. To be used for assumed-rank
52 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
54 enum gfc_array_kind akind
;
57 akind
= GFC_ARRAY_POINTER_CONT
;
58 else if (attr
.allocatable
)
59 akind
= GFC_ARRAY_ALLOCATABLE
;
61 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
63 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
64 scalar
= TREE_TYPE (scalar
);
65 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
66 akind
, !(attr
.pointer
|| attr
.target
));
70 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
74 type
= get_scalar_to_descriptor_type (scalar
, attr
);
75 desc
= gfc_create_var (type
, "desc");
76 DECL_ARTIFICIAL (desc
) = 1;
78 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
79 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
80 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
81 gfc_get_dtype (type
));
82 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
84 /* Copy pointer address back - but only if it could have changed and
85 if the actual argument is a pointer and not, e.g., NULL(). */
86 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
87 gfc_add_modify (&se
->post
, scalar
,
88 fold_convert (TREE_TYPE (scalar
),
89 gfc_conv_descriptor_data_get (desc
)));
94 /* This is the seed for an eventual trans-class.c
96 The following parameters should not be used directly since they might
97 in future implementations. Use the corresponding APIs. */
98 #define CLASS_DATA_FIELD 0
99 #define CLASS_VPTR_FIELD 1
100 #define CLASS_LEN_FIELD 2
101 #define VTABLE_HASH_FIELD 0
102 #define VTABLE_SIZE_FIELD 1
103 #define VTABLE_EXTENDS_FIELD 2
104 #define VTABLE_DEF_INIT_FIELD 3
105 #define VTABLE_COPY_FIELD 4
106 #define VTABLE_FINAL_FIELD 5
110 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
114 vec
<constructor_elt
, va_gc
> *init
= NULL
;
116 field
= TYPE_FIELDS (TREE_TYPE (decl
));
117 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
118 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
120 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
121 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
123 return build_constructor (TREE_TYPE (decl
), init
);
128 gfc_class_data_get (tree decl
)
131 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
132 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
133 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
135 return fold_build3_loc (input_location
, COMPONENT_REF
,
136 TREE_TYPE (data
), decl
, data
,
142 gfc_class_vptr_get (tree decl
)
145 /* For class arrays decl may be a temporary descriptor handle, the vptr is
146 then available through the saved descriptor. */
147 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
148 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
149 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
150 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
151 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
152 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
154 return fold_build3_loc (input_location
, COMPONENT_REF
,
155 TREE_TYPE (vptr
), decl
, vptr
,
161 gfc_class_len_get (tree decl
)
164 /* For class arrays decl may be a temporary descriptor handle, the len is
165 then available through the saved descriptor. */
166 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
167 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
168 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
169 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
170 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
171 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
173 return fold_build3_loc (input_location
, COMPONENT_REF
,
174 TREE_TYPE (len
), decl
, len
,
179 /* Get the specified FIELD from the VPTR. */
182 vptr_field_get (tree vptr
, int fieldno
)
185 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
186 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
188 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
189 TREE_TYPE (field
), vptr
, field
,
196 /* Get the field from the class' vptr. */
199 class_vtab_field_get (tree decl
, int fieldno
)
202 vptr
= gfc_class_vptr_get (decl
);
203 return vptr_field_get (vptr
, fieldno
);
207 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
209 #define VTAB_GET_FIELD_GEN(name, field) tree \
210 gfc_class_vtab_## name ##_get (tree cl) \
212 return class_vtab_field_get (cl, field); \
216 gfc_vptr_## name ##_get (tree vptr) \
218 return vptr_field_get (vptr, field); \
221 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
222 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
223 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
224 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
225 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
228 /* The size field is returned as an array index type. Therefore treat
229 it and only it specially. */
232 gfc_class_vtab_size_get (tree cl
)
235 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
236 /* Always return size as an array index type. */
237 size
= fold_convert (gfc_array_index_type
, size
);
243 gfc_vptr_size_get (tree vptr
)
246 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
247 /* Always return size as an array index type. */
248 size
= fold_convert (gfc_array_index_type
, size
);
254 #undef CLASS_DATA_FIELD
255 #undef CLASS_VPTR_FIELD
256 #undef VTABLE_HASH_FIELD
257 #undef VTABLE_SIZE_FIELD
258 #undef VTABLE_EXTENDS_FIELD
259 #undef VTABLE_DEF_INIT_FIELD
260 #undef VTABLE_COPY_FIELD
261 #undef VTABLE_FINAL_FIELD
264 /* Search for the last _class ref in the chain of references of this
265 expression and cut the chain there. Albeit this routine is similiar
266 to class.c::gfc_add_component_ref (), is there a significant
267 difference: gfc_add_component_ref () concentrates on an array ref to
268 be the last ref in the chain. This routine is oblivious to the kind
269 of refs following. */
272 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
275 gfc_ref
*ref
, *class_ref
, *tail
;
277 /* Find the last class reference. */
279 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
281 if (ref
->type
== REF_COMPONENT
282 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
285 if (ref
->next
== NULL
)
289 /* Remove and store all subsequent references after the
293 tail
= class_ref
->next
;
294 class_ref
->next
= NULL
;
302 base_expr
= gfc_expr_to_initialize (e
);
304 /* Restore the original tail expression. */
307 gfc_free_ref_list (class_ref
->next
);
308 class_ref
->next
= tail
;
312 gfc_free_ref_list (e
->ref
);
319 /* Reset the vptr to the declared type, e.g. after deallocation. */
322 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
324 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
329 /* If we have a class array, we need go back to the class
331 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
332 && lhs
->ref
->next
->type
== REF_ARRAY
333 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
334 && lhs
->ref
->type
== REF_COMPONENT
335 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
337 gfc_free_ref_list (lhs
->ref
);
341 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
342 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
343 && ref
->next
->next
->type
== REF_ARRAY
344 && ref
->next
->next
->u
.ar
.type
== AR_FULL
345 && ref
->next
->type
== REF_COMPONENT
346 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
348 gfc_free_ref_list (ref
->next
);
352 gfc_add_vptr_component (lhs
);
354 if (UNLIMITED_POLY (e
))
355 rhs
= gfc_get_null_expr (NULL
);
358 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
359 rhs
= gfc_lval_expr_from_sym (vtab
);
361 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
362 gfc_add_expr_to_block (block
, tmp
);
368 /* Reset the len for unlimited polymorphic objects. */
371 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
375 e
= gfc_find_and_cut_at_last_class_ref (expr
);
376 gfc_add_len_component (e
);
377 gfc_init_se (&se_len
, NULL
);
378 gfc_conv_expr (&se_len
, e
);
379 gfc_add_modify (block
, se_len
.expr
,
380 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
385 /* Obtain the vptr of the last class reference in an expression.
386 Return NULL_TREE if no class reference is found. */
389 gfc_get_vptr_from_expr (tree expr
)
394 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
396 type
= TREE_TYPE (tmp
);
399 if (GFC_CLASS_TYPE_P (type
))
400 return gfc_class_vptr_get (tmp
);
401 if (type
!= TYPE_CANONICAL (type
))
402 type
= TYPE_CANONICAL (type
);
406 if (TREE_CODE (tmp
) == VAR_DECL
)
414 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
417 tree tmp
, tmp2
, type
;
419 gfc_conv_descriptor_data_set (block
, lhs_desc
,
420 gfc_conv_descriptor_data_get (rhs_desc
));
421 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
422 gfc_conv_descriptor_offset_get (rhs_desc
));
424 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
425 gfc_conv_descriptor_dtype (rhs_desc
));
427 /* Assign the dimension as range-ref. */
428 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
429 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
431 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
432 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
433 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
434 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
435 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
436 gfc_add_modify (block
, tmp
, tmp2
);
440 /* Takes a derived type expression and returns the address of a temporary
441 class object of the 'declared' type. If vptr is not NULL, this is
442 used for the temporary class object.
443 optional_alloc_ptr is false when the dummy is neither allocatable
444 nor a pointer; that's only relevant for the optional handling. */
446 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
447 gfc_typespec class_ts
, tree vptr
, bool optional
,
448 bool optional_alloc_ptr
)
451 tree cond_optional
= NULL_TREE
;
457 /* The derived type needs to be converted to a temporary
459 tmp
= gfc_typenode_for_spec (&class_ts
);
460 var
= gfc_create_var (tmp
, "class");
463 ctree
= gfc_class_vptr_get (var
);
465 if (vptr
!= NULL_TREE
)
467 /* Use the dynamic vptr. */
472 /* In this case the vtab corresponds to the derived type and the
473 vptr must point to it. */
474 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
476 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
478 gfc_add_modify (&parmse
->pre
, ctree
,
479 fold_convert (TREE_TYPE (ctree
), tmp
));
481 /* Now set the data field. */
482 ctree
= gfc_class_data_get (var
);
485 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
487 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
489 /* For an array reference in an elemental procedure call we need
490 to retain the ss to provide the scalarized array reference. */
491 gfc_conv_expr_reference (parmse
, e
);
492 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
494 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
496 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
497 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
502 ss
= gfc_walk_expr (e
);
503 if (ss
== gfc_ss_terminator
)
506 gfc_conv_expr_reference (parmse
, e
);
508 /* Scalar to an assumed-rank array. */
509 if (class_ts
.u
.derived
->components
->as
)
512 type
= get_scalar_to_descriptor_type (parmse
->expr
,
514 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
515 gfc_get_dtype (type
));
517 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
518 TREE_TYPE (parmse
->expr
),
519 cond_optional
, parmse
->expr
,
520 fold_convert (TREE_TYPE (parmse
->expr
),
522 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
526 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
528 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
530 fold_convert (TREE_TYPE (tmp
),
532 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
538 gfc_init_block (&block
);
541 gfc_conv_expr_descriptor (parmse
, e
);
543 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
545 gcc_assert (class_ts
.u
.derived
->components
->as
->type
547 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
551 if (gfc_expr_attr (e
).codimension
)
552 parmse
->expr
= fold_build1_loc (input_location
,
556 gfc_add_modify (&block
, ctree
, parmse
->expr
);
561 tmp
= gfc_finish_block (&block
);
563 gfc_init_block (&block
);
564 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
566 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
567 gfc_finish_block (&block
));
568 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
571 gfc_add_block_to_block (&parmse
->pre
, &block
);
575 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
576 && class_ts
.u
.derived
->components
->ts
.u
.derived
577 ->attr
.unlimited_polymorphic
)
579 /* Take care about initializing the _len component correctly. */
580 ctree
= gfc_class_len_get (var
);
581 if (UNLIMITED_POLY (e
))
586 len
= gfc_copy_expr (e
);
587 gfc_add_len_component (len
);
588 gfc_init_se (&se
, NULL
);
589 gfc_conv_expr (&se
, len
);
591 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
592 cond_optional
, se
.expr
,
593 fold_convert (TREE_TYPE (se
.expr
),
599 tmp
= integer_zero_node
;
600 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
603 /* Pass the address of the class object. */
604 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
606 if (optional
&& optional_alloc_ptr
)
607 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
608 TREE_TYPE (parmse
->expr
),
609 cond_optional
, parmse
->expr
,
610 fold_convert (TREE_TYPE (parmse
->expr
),
615 /* Create a new class container, which is required as scalar coarrays
616 have an array descriptor while normal scalars haven't. Optionally,
617 NULL pointer checks are added if the argument is OPTIONAL. */
620 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
621 gfc_typespec class_ts
, bool optional
)
623 tree var
, ctree
, tmp
;
628 gfc_init_block (&block
);
631 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
633 if (ref
->type
== REF_COMPONENT
634 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
638 if (class_ref
== NULL
639 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
640 tmp
= e
->symtree
->n
.sym
->backend_decl
;
643 /* Remove everything after the last class reference, convert the
644 expression and then recover its tailend once more. */
646 ref
= class_ref
->next
;
647 class_ref
->next
= NULL
;
648 gfc_init_se (&tmpse
, NULL
);
649 gfc_conv_expr (&tmpse
, e
);
650 class_ref
->next
= ref
;
654 var
= gfc_typenode_for_spec (&class_ts
);
655 var
= gfc_create_var (var
, "class");
657 ctree
= gfc_class_vptr_get (var
);
658 gfc_add_modify (&block
, ctree
,
659 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
661 ctree
= gfc_class_data_get (var
);
662 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
663 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
665 /* Pass the address of the class object. */
666 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
670 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
673 tmp
= gfc_finish_block (&block
);
675 gfc_init_block (&block
);
676 tmp2
= gfc_class_data_get (var
);
677 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
679 tmp2
= gfc_finish_block (&block
);
681 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
683 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
686 gfc_add_block_to_block (&parmse
->pre
, &block
);
690 /* Takes an intrinsic type expression and returns the address of a temporary
691 class object of the 'declared' type. */
693 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
694 gfc_typespec class_ts
)
702 /* The intrinsic type needs to be converted to a temporary
704 tmp
= gfc_typenode_for_spec (&class_ts
);
705 var
= gfc_create_var (tmp
, "class");
708 ctree
= gfc_class_vptr_get (var
);
710 vtab
= gfc_find_vtab (&e
->ts
);
712 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
713 gfc_add_modify (&parmse
->pre
, ctree
,
714 fold_convert (TREE_TYPE (ctree
), tmp
));
716 /* Now set the data field. */
717 ctree
= gfc_class_data_get (var
);
718 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
720 /* For an array reference in an elemental procedure call we need
721 to retain the ss to provide the scalarized array reference. */
722 gfc_conv_expr_reference (parmse
, e
);
723 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
724 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
728 ss
= gfc_walk_expr (e
);
729 if (ss
== gfc_ss_terminator
)
732 gfc_conv_expr_reference (parmse
, e
);
733 if (class_ts
.u
.derived
->components
->as
734 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
736 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
738 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
739 TREE_TYPE (ctree
), tmp
);
742 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
743 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
748 parmse
->use_offset
= 1;
749 gfc_conv_expr_descriptor (parmse
, e
);
750 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
752 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
753 TREE_TYPE (ctree
), parmse
->expr
);
754 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
757 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
761 gcc_assert (class_ts
.type
== BT_CLASS
);
762 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
763 && class_ts
.u
.derived
->components
->ts
.u
.derived
764 ->attr
.unlimited_polymorphic
)
766 ctree
= gfc_class_len_get (var
);
767 /* When the actual arg is a char array, then set the _len component of the
768 unlimited polymorphic entity, too. */
769 if (e
->ts
.type
== BT_CHARACTER
)
771 /* Start with parmse->string_length because this seems to be set to a
772 correct value more often. */
773 if (parmse
->string_length
)
774 tmp
= parmse
->string_length
;
775 /* When the string_length is not yet set, then try the backend_decl of
777 else if (e
->ts
.u
.cl
->backend_decl
)
778 tmp
= e
->ts
.u
.cl
->backend_decl
;
779 /* If both of the above approaches fail, then try to generate an
780 expression from the input, which is only feasible currently, when the
781 expression can be evaluated to a constant one. */
784 /* Try to simplify the expression. */
785 gfc_simplify_expr (e
, 0);
786 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
788 /* Amazingly all data is present to compute the length of a
789 constant string, but the expression is not yet there. */
790 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
792 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
793 e
->value
.character
.length
);
794 gfc_conv_const_charlen (e
->ts
.u
.cl
);
795 e
->ts
.u
.cl
->resolved
= 1;
796 tmp
= e
->ts
.u
.cl
->backend_decl
;
800 gfc_error ("Can't compute the length of the char array at %L.",
806 tmp
= integer_zero_node
;
808 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
810 else if (class_ts
.type
== BT_CLASS
811 && class_ts
.u
.derived
->components
812 && class_ts
.u
.derived
->components
->ts
.u
813 .derived
->attr
.unlimited_polymorphic
)
815 ctree
= gfc_class_len_get (var
);
816 gfc_add_modify (&parmse
->pre
, ctree
,
817 fold_convert (TREE_TYPE (ctree
),
820 /* Pass the address of the class object. */
821 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
825 /* Takes a scalarized class array expression and returns the
826 address of a temporary scalar class object of the 'declared'
828 OOP-TODO: This could be improved by adding code that branched on
829 the dynamic type being the same as the declared type. In this case
830 the original class expression can be passed directly.
831 optional_alloc_ptr is false when the dummy is neither allocatable
832 nor a pointer; that's relevant for the optional handling.
833 Set copyback to true if class container's _data and _vtab pointers
834 might get modified. */
837 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
838 bool elemental
, bool copyback
, bool optional
,
839 bool optional_alloc_ptr
)
845 tree cond
= NULL_TREE
;
846 tree slen
= NULL_TREE
;
850 bool full_array
= false;
852 gfc_init_block (&block
);
855 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
857 if (ref
->type
== REF_COMPONENT
858 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
861 if (ref
->next
== NULL
)
865 if ((ref
== NULL
|| class_ref
== ref
)
866 && (!class_ts
.u
.derived
->components
->as
867 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
870 /* Test for FULL_ARRAY. */
871 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
872 && gfc_expr_attr (e
).dimension
)
875 gfc_is_class_array_ref (e
, &full_array
);
877 /* The derived type needs to be converted to a temporary
879 tmp
= gfc_typenode_for_spec (&class_ts
);
880 var
= gfc_create_var (tmp
, "class");
883 ctree
= gfc_class_data_get (var
);
884 if (class_ts
.u
.derived
->components
->as
885 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
889 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
891 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
892 gfc_get_dtype (type
));
894 tmp
= gfc_class_data_get (parmse
->expr
);
895 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
896 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
898 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
901 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
905 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
906 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
907 TREE_TYPE (ctree
), parmse
->expr
);
908 gfc_add_modify (&block
, ctree
, parmse
->expr
);
911 /* Return the data component, except in the case of scalarized array
912 references, where nullification of the cannot occur and so there
914 if (!elemental
&& full_array
&& copyback
)
916 if (class_ts
.u
.derived
->components
->as
917 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
920 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
921 gfc_conv_descriptor_data_get (ctree
));
923 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
926 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
930 ctree
= gfc_class_vptr_get (var
);
932 /* The vptr is the second field of the actual argument.
933 First we have to find the corresponding class reference. */
936 if (class_ref
== NULL
937 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
939 tmp
= e
->symtree
->n
.sym
->backend_decl
;
940 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
941 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
942 slen
= integer_zero_node
;
946 /* Remove everything after the last class reference, convert the
947 expression and then recover its tailend once more. */
949 ref
= class_ref
->next
;
950 class_ref
->next
= NULL
;
951 gfc_init_se (&tmpse
, NULL
);
952 gfc_conv_expr (&tmpse
, e
);
953 class_ref
->next
= ref
;
955 slen
= tmpse
.string_length
;
958 gcc_assert (tmp
!= NULL_TREE
);
960 /* Dereference if needs be. */
961 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
962 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
964 vptr
= gfc_class_vptr_get (tmp
);
965 gfc_add_modify (&block
, ctree
,
966 fold_convert (TREE_TYPE (ctree
), vptr
));
968 /* Return the vptr component, except in the case of scalarized array
969 references, where the dynamic type cannot change. */
970 if (!elemental
&& full_array
&& copyback
)
971 gfc_add_modify (&parmse
->post
, vptr
,
972 fold_convert (TREE_TYPE (vptr
), ctree
));
974 /* For unlimited polymorphic objects also set the _len component. */
975 if (class_ts
.type
== BT_CLASS
976 && class_ts
.u
.derived
->components
977 && class_ts
.u
.derived
->components
->ts
.u
978 .derived
->attr
.unlimited_polymorphic
)
980 ctree
= gfc_class_len_get (var
);
981 if (UNLIMITED_POLY (e
))
982 tmp
= gfc_class_len_get (tmp
);
983 else if (e
->ts
.type
== BT_CHARACTER
)
985 gcc_assert (slen
!= NULL_TREE
);
989 tmp
= integer_zero_node
;
990 gfc_add_modify (&parmse
->pre
, ctree
,
991 fold_convert (TREE_TYPE (ctree
), tmp
));
998 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
999 /* parmse->pre may contain some preparatory instructions for the
1000 temporary array descriptor. Those may only be executed when the
1001 optional argument is set, therefore add parmse->pre's instructions
1002 to block, which is later guarded by an if (optional_arg_given). */
1003 gfc_add_block_to_block (&parmse
->pre
, &block
);
1004 block
.head
= parmse
->pre
.head
;
1005 parmse
->pre
.head
= NULL_TREE
;
1006 tmp
= gfc_finish_block (&block
);
1008 if (optional_alloc_ptr
)
1009 tmp2
= build_empty_stmt (input_location
);
1012 gfc_init_block (&block
);
1014 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1015 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1016 null_pointer_node
));
1017 tmp2
= gfc_finish_block (&block
);
1020 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1022 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1025 gfc_add_block_to_block (&parmse
->pre
, &block
);
1027 /* Pass the address of the class object. */
1028 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1030 if (optional
&& optional_alloc_ptr
)
1031 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1032 TREE_TYPE (parmse
->expr
),
1034 fold_convert (TREE_TYPE (parmse
->expr
),
1035 null_pointer_node
));
1039 /* Given a class array declaration and an index, returns the address
1040 of the referenced element. */
1043 gfc_get_class_array_ref (tree index
, tree class_decl
)
1045 tree data
= gfc_class_data_get (class_decl
);
1046 tree size
= gfc_class_vtab_size_get (class_decl
);
1047 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1048 gfc_array_index_type
,
1051 data
= gfc_conv_descriptor_data_get (data
);
1052 ptr
= fold_convert (pvoid_type_node
, data
);
1053 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1054 return fold_convert (TREE_TYPE (data
), ptr
);
1058 /* Copies one class expression to another, assuming that if either
1059 'to' or 'from' are arrays they are packed. Should 'from' be
1060 NULL_TREE, the initialization expression for 'to' is used, assuming
1061 that the _vptr is set. */
1064 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1074 vec
<tree
, va_gc
> *args
;
1081 /* To prevent warnings on uninitialized variables. */
1082 from_len
= to_len
= NULL_TREE
;
1084 if (from
!= NULL_TREE
)
1085 fcn
= gfc_class_vtab_copy_get (from
);
1087 fcn
= gfc_class_vtab_copy_get (to
);
1089 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1091 if (from
!= NULL_TREE
)
1092 from_data
= gfc_class_data_get (from
);
1094 from_data
= gfc_class_vtab_def_init_get (to
);
1098 if (from
!= NULL_TREE
&& unlimited
)
1099 from_len
= gfc_class_len_get (from
);
1101 from_len
= integer_zero_node
;
1104 to_data
= gfc_class_data_get (to
);
1106 to_len
= gfc_class_len_get (to
);
1108 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1110 stmtblock_t loopbody
;
1115 gfc_init_block (&body
);
1116 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1117 gfc_array_index_type
, nelems
,
1118 gfc_index_one_node
);
1119 nelems
= gfc_evaluate_now (tmp
, &body
);
1120 index
= gfc_create_var (gfc_array_index_type
, "S");
1122 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
1124 from_ref
= gfc_get_class_array_ref (index
, from
);
1125 vec_safe_push (args
, from_ref
);
1128 vec_safe_push (args
, from_data
);
1130 to_ref
= gfc_get_class_array_ref (index
, to
);
1131 vec_safe_push (args
, to_ref
);
1133 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1135 /* Build the body of the loop. */
1136 gfc_init_block (&loopbody
);
1137 gfc_add_expr_to_block (&loopbody
, tmp
);
1139 /* Build the loop and return. */
1140 gfc_init_loopinfo (&loop
);
1142 loop
.from
[0] = gfc_index_zero_node
;
1143 loop
.loopvar
[0] = index
;
1144 loop
.to
[0] = nelems
;
1145 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1146 gfc_init_block (&ifbody
);
1147 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1148 stdcopy
= gfc_finish_block (&ifbody
);
1149 /* In initialization mode from_len is a constant zero. */
1150 if (unlimited
&& !integer_zerop (from_len
))
1152 vec_safe_push (args
, from_len
);
1153 vec_safe_push (args
, to_len
);
1154 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1155 /* Build the body of the loop. */
1156 gfc_init_block (&loopbody
);
1157 gfc_add_expr_to_block (&loopbody
, tmp
);
1159 /* Build the loop and return. */
1160 gfc_init_loopinfo (&loop
);
1162 loop
.from
[0] = gfc_index_zero_node
;
1163 loop
.loopvar
[0] = index
;
1164 loop
.to
[0] = nelems
;
1165 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1166 gfc_init_block (&ifbody
);
1167 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1168 extcopy
= gfc_finish_block (&ifbody
);
1170 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1171 boolean_type_node
, from_len
,
1173 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1174 void_type_node
, tmp
, extcopy
, stdcopy
);
1175 gfc_add_expr_to_block (&body
, tmp
);
1176 tmp
= gfc_finish_block (&body
);
1180 gfc_add_expr_to_block (&body
, stdcopy
);
1181 tmp
= gfc_finish_block (&body
);
1183 gfc_cleanup_loop (&loop
);
1187 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
1188 vec_safe_push (args
, from_data
);
1189 vec_safe_push (args
, to_data
);
1190 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1192 /* In initialization mode from_len is a constant zero. */
1193 if (unlimited
&& !integer_zerop (from_len
))
1195 vec_safe_push (args
, from_len
);
1196 vec_safe_push (args
, to_len
);
1197 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1198 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1199 boolean_type_node
, from_len
,
1201 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1202 void_type_node
, tmp
, extcopy
, stdcopy
);
1208 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1209 if (from
== NULL_TREE
)
1212 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1214 from_data
, null_pointer_node
);
1215 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1216 void_type_node
, cond
,
1217 tmp
, build_empty_stmt (input_location
));
1225 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1227 gfc_actual_arglist
*actual
;
1232 actual
= gfc_get_actual_arglist ();
1233 actual
->expr
= gfc_copy_expr (rhs
);
1234 actual
->next
= gfc_get_actual_arglist ();
1235 actual
->next
->expr
= gfc_copy_expr (lhs
);
1236 ppc
= gfc_copy_expr (obj
);
1237 gfc_add_vptr_component (ppc
);
1238 gfc_add_component_ref (ppc
, "_copy");
1239 ppc_code
= gfc_get_code (EXEC_CALL
);
1240 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1241 /* Although '_copy' is set to be elemental in class.c, it is
1242 not staying that way. Find out why, sometime.... */
1243 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1244 ppc_code
->ext
.actual
= actual
;
1245 ppc_code
->expr1
= ppc
;
1246 /* Since '_copy' is elemental, the scalarizer will take care
1247 of arrays in gfc_trans_call. */
1248 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1249 gfc_free_statements (ppc_code
);
1251 if (UNLIMITED_POLY(obj
))
1253 /* Check if rhs is non-NULL. */
1255 gfc_init_se (&src
, NULL
);
1256 gfc_conv_expr (&src
, rhs
);
1257 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1258 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1259 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1260 null_pointer_node
));
1261 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1262 build_empty_stmt (input_location
));
1268 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1269 A MEMCPY is needed to copy the full data from the default initializer
1270 of the dynamic type. */
1273 gfc_trans_class_init_assign (gfc_code
*code
)
1277 gfc_se dst
,src
,memsz
;
1278 gfc_expr
*lhs
, *rhs
, *sz
;
1280 gfc_start_block (&block
);
1282 lhs
= gfc_copy_expr (code
->expr1
);
1283 gfc_add_data_component (lhs
);
1285 rhs
= gfc_copy_expr (code
->expr1
);
1286 gfc_add_vptr_component (rhs
);
1288 /* Make sure that the component backend_decls have been built, which
1289 will not have happened if the derived types concerned have not
1291 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1292 gfc_add_def_init_component (rhs
);
1293 /* The _def_init is always scalar. */
1296 if (code
->expr1
->ts
.type
== BT_CLASS
1297 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1298 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1301 sz
= gfc_copy_expr (code
->expr1
);
1302 gfc_add_vptr_component (sz
);
1303 gfc_add_size_component (sz
);
1305 gfc_init_se (&dst
, NULL
);
1306 gfc_init_se (&src
, NULL
);
1307 gfc_init_se (&memsz
, NULL
);
1308 gfc_conv_expr (&dst
, lhs
);
1309 gfc_conv_expr (&src
, rhs
);
1310 gfc_conv_expr (&memsz
, sz
);
1311 gfc_add_block_to_block (&block
, &src
.pre
);
1312 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1314 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1316 if (UNLIMITED_POLY(code
->expr1
))
1318 /* Check if _def_init is non-NULL. */
1319 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1320 boolean_type_node
, src
.expr
,
1321 fold_convert (TREE_TYPE (src
.expr
),
1322 null_pointer_node
));
1323 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1324 tmp
, build_empty_stmt (input_location
));
1328 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1329 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1331 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1332 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1334 build_empty_stmt (input_location
));
1337 gfc_add_expr_to_block (&block
, tmp
);
1339 return gfc_finish_block (&block
);
1343 /* Translate an assignment to a CLASS object
1344 (pointer or ordinary assignment). */
1347 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1355 gfc_start_block (&block
);
1358 while (ref
&& ref
->next
)
1361 /* Class valued proc_pointer assignments do not need any further
1363 if (ref
&& ref
->type
== REF_COMPONENT
1364 && ref
->u
.c
.component
->attr
.proc_pointer
1365 && expr2
->expr_type
== EXPR_VARIABLE
1366 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1367 && op
== EXEC_POINTER_ASSIGN
)
1370 if (expr2
->ts
.type
!= BT_CLASS
)
1372 /* Insert an additional assignment which sets the '_vptr' field. */
1373 gfc_symbol
*vtab
= NULL
;
1376 lhs
= gfc_copy_expr (expr1
);
1377 gfc_add_vptr_component (lhs
);
1379 if (UNLIMITED_POLY (expr1
)
1380 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1382 rhs
= gfc_get_null_expr (&expr2
->where
);
1386 if (expr2
->expr_type
== EXPR_NULL
)
1387 vtab
= gfc_find_vtab (&expr1
->ts
);
1389 vtab
= gfc_find_vtab (&expr2
->ts
);
1392 rhs
= gfc_get_expr ();
1393 rhs
->expr_type
= EXPR_VARIABLE
;
1394 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1398 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1399 gfc_add_expr_to_block (&block
, tmp
);
1401 gfc_free_expr (lhs
);
1402 gfc_free_expr (rhs
);
1404 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1406 /* F2003:C717 only sequence and bind-C types can come here. */
1407 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1408 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1409 gfc_add_data_component (expr2
);
1412 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1414 /* Insert an additional assignment which sets the '_vptr' field. */
1415 lhs
= gfc_copy_expr (expr1
);
1416 gfc_add_vptr_component (lhs
);
1418 rhs
= gfc_copy_expr (expr2
);
1419 gfc_add_vptr_component (rhs
);
1421 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1422 gfc_add_expr_to_block (&block
, tmp
);
1424 gfc_free_expr (lhs
);
1425 gfc_free_expr (rhs
);
1428 /* Do the actual CLASS assignment. */
1429 if (expr2
->ts
.type
== BT_CLASS
1430 && !CLASS_DATA (expr2
)->attr
.dimension
)
1432 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1433 || !CLASS_DATA (expr2
)->attr
.dimension
)
1434 gfc_add_data_component (expr1
);
1438 if (op
== EXEC_ASSIGN
)
1439 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1440 else if (op
== EXEC_POINTER_ASSIGN
)
1441 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1445 gfc_add_expr_to_block (&block
, tmp
);
1447 return gfc_finish_block (&block
);
1451 /* End of prototype trans-class.c */
1455 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1457 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1458 gfc_warning (OPT_Wrealloc_lhs
,
1459 "Code for reallocating the allocatable array at %L will "
1461 else if (warn_realloc_lhs_all
)
1462 gfc_warning (OPT_Wrealloc_lhs_all
,
1463 "Code for reallocating the allocatable variable at %L "
1464 "will be added", where
);
1468 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
);
1469 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1472 /* Copy the scalarization loop variables. */
1475 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1478 dest
->loop
= src
->loop
;
1482 /* Initialize a simple expression holder.
1484 Care must be taken when multiple se are created with the same parent.
1485 The child se must be kept in sync. The easiest way is to delay creation
1486 of a child se until after after the previous se has been translated. */
1489 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1491 memset (se
, 0, sizeof (gfc_se
));
1492 gfc_init_block (&se
->pre
);
1493 gfc_init_block (&se
->post
);
1495 se
->parent
= parent
;
1498 gfc_copy_se_loopvars (se
, parent
);
1502 /* Advances to the next SS in the chain. Use this rather than setting
1503 se->ss = se->ss->next because all the parents needs to be kept in sync.
1507 gfc_advance_se_ss_chain (gfc_se
* se
)
1512 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1515 /* Walk down the parent chain. */
1518 /* Simple consistency check. */
1519 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1520 || p
->parent
->ss
->nested_ss
== p
->ss
);
1522 /* If we were in a nested loop, the next scalarized expression can be
1523 on the parent ss' next pointer. Thus we should not take the next
1524 pointer blindly, but rather go up one nest level as long as next
1525 is the end of chain. */
1527 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1537 /* Ensures the result of the expression as either a temporary variable
1538 or a constant so that it can be used repeatedly. */
1541 gfc_make_safe_expr (gfc_se
* se
)
1545 if (CONSTANT_CLASS_P (se
->expr
))
1548 /* We need a temporary for this result. */
1549 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1550 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1555 /* Return an expression which determines if a dummy parameter is present.
1556 Also used for arguments to procedures with multiple entry points. */
1559 gfc_conv_expr_present (gfc_symbol
* sym
)
1563 gcc_assert (sym
->attr
.dummy
);
1564 decl
= gfc_get_symbol_decl (sym
);
1566 /* Intrinsic scalars with VALUE attribute which are passed by value
1567 use a hidden argument to denote the present status. */
1568 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1569 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1570 && !sym
->attr
.dimension
)
1572 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1575 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1577 strcpy (&name
[1], sym
->name
);
1578 tree_name
= get_identifier (name
);
1580 /* Walk function argument list to find hidden arg. */
1581 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1582 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1583 if (DECL_NAME (cond
) == tree_name
)
1590 if (TREE_CODE (decl
) != PARM_DECL
)
1592 /* Array parameters use a temporary descriptor, we want the real
1594 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1595 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1596 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1599 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1600 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1602 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1603 as actual argument to denote absent dummies. For array descriptors,
1604 we thus also need to check the array descriptor. For BT_CLASS, it
1605 can also occur for scalars and F2003 due to type->class wrapping and
1606 class->class wrapping. Note further that BT_CLASS always uses an
1607 array descriptor for arrays, also for explicit-shape/assumed-size. */
1609 if (!sym
->attr
.allocatable
1610 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1611 || (sym
->ts
.type
== BT_CLASS
1612 && !CLASS_DATA (sym
)->attr
.allocatable
1613 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1614 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1615 || sym
->ts
.type
== BT_CLASS
))
1619 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1620 || sym
->as
->type
== AS_ASSUMED_RANK
1621 || sym
->attr
.codimension
))
1622 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1624 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1625 if (sym
->ts
.type
== BT_CLASS
)
1626 tmp
= gfc_class_data_get (tmp
);
1627 tmp
= gfc_conv_array_data (tmp
);
1629 else if (sym
->ts
.type
== BT_CLASS
)
1630 tmp
= gfc_class_data_get (decl
);
1634 if (tmp
!= NULL_TREE
)
1636 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1637 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1638 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1639 boolean_type_node
, cond
, tmp
);
1647 /* Converts a missing, dummy argument into a null or zero. */
1650 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1655 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1659 /* Create a temporary and convert it to the correct type. */
1660 tmp
= gfc_get_int_type (kind
);
1661 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1664 /* Test for a NULL value. */
1665 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1666 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1667 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1668 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1672 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1674 build_zero_cst (TREE_TYPE (se
->expr
)));
1675 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1679 if (ts
.type
== BT_CHARACTER
)
1681 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1682 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1683 present
, se
->string_length
, tmp
);
1684 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1685 se
->string_length
= tmp
;
1691 /* Get the character length of an expression, looking through gfc_refs
1695 gfc_get_expr_charlen (gfc_expr
*e
)
1700 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1701 && e
->ts
.type
== BT_CHARACTER
);
1703 length
= NULL
; /* To silence compiler warning. */
1705 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1708 gfc_init_se (&tmpse
, NULL
);
1709 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1710 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1714 /* First candidate: if the variable is of type CHARACTER, the
1715 expression's length could be the length of the character
1717 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1718 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1720 /* Look through the reference chain for component references. */
1721 for (r
= e
->ref
; r
; r
= r
->next
)
1726 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1727 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1735 /* We should never got substring references here. These will be
1736 broken down by the scalarizer. */
1742 gcc_assert (length
!= NULL
);
1747 /* Return for an expression the backend decl of the coarray. */
1750 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1754 gfc_ref
*ref
, *comp_ref
= NULL
;
1756 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1758 /* Not-implemented diagnostic. */
1759 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1760 if (ref
->type
== REF_COMPONENT
)
1763 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1764 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1765 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1766 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1767 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1768 && !ref
->u
.c
.component
->attr
.codimension
1769 && (ref
->u
.c
.component
->attr
.pointer
1770 || ref
->u
.c
.component
->attr
.allocatable
)))
1771 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1772 "component of the coindexed coarray at %L is not yet "
1773 "supported", &expr
->where
);
1776 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1777 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1778 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1779 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1781 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1782 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1783 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1784 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1785 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1786 "not yet supported", &expr
->where
);
1790 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1791 general not possible as the required stride multiplier might be not
1792 a multiple of c_sizeof(b). In case of noncoindexed access, the
1793 scalarizer often takes care of it - for coarrays, it always fails. */
1794 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1795 if (ref
->type
== REF_COMPONENT
1796 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1797 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1798 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1799 && ref
->u
.c
.component
->attr
.codimension
)))
1803 for ( ; ref
; ref
= ref
->next
)
1804 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1806 for ( ; ref
; ref
= ref
->next
)
1807 if (ref
->type
== REF_COMPONENT
)
1808 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1809 "with an array partref is not yet supported",
1813 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1814 gcc_assert (caf_decl
);
1815 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1816 caf_decl
= gfc_class_data_get (caf_decl
);
1817 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1820 /* The following code assumes that the coarray is a component reachable via
1821 only scalar components/variables; the Fortran standard guarantees this. */
1823 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1824 if (ref
->type
== REF_COMPONENT
)
1826 gfc_component
*comp
= ref
->u
.c
.component
;
1828 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1829 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1830 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1831 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1832 comp
->backend_decl
, NULL_TREE
);
1833 if (comp
->ts
.type
== BT_CLASS
)
1834 caf_decl
= gfc_class_data_get (caf_decl
);
1835 if (comp
->attr
.codimension
)
1841 gcc_assert (found
&& caf_decl
);
1846 /* Obtain the Coarray token - and optionally also the offset. */
1849 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1854 /* Coarray token. */
1855 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1857 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1858 == GFC_ARRAY_ALLOCATABLE
1859 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1860 *token
= gfc_conv_descriptor_token (caf_decl
);
1862 else if (DECL_LANG_SPECIFIC (caf_decl
)
1863 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1864 *token
= GFC_DECL_TOKEN (caf_decl
);
1867 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1868 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1869 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1875 /* Offset between the coarray base address and the address wanted. */
1876 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1877 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1878 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1879 *offset
= build_int_cst (gfc_array_index_type
, 0);
1880 else if (DECL_LANG_SPECIFIC (caf_decl
)
1881 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1882 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1883 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1884 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1886 *offset
= build_int_cst (gfc_array_index_type
, 0);
1888 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1889 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1891 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1892 tmp
= gfc_conv_descriptor_data_get (tmp
);
1894 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1895 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1898 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1902 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1903 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1905 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1906 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1909 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1913 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1914 fold_convert (gfc_array_index_type
, *offset
),
1915 fold_convert (gfc_array_index_type
, tmp
));
1919 /* Convert the coindex of a coarray into an image index; the result is
1920 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1921 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1924 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1927 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1931 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1932 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1934 gcc_assert (ref
!= NULL
);
1936 img_idx
= integer_zero_node
;
1937 extent
= integer_one_node
;
1938 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1939 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1941 gfc_init_se (&se
, NULL
);
1942 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1943 gfc_add_block_to_block (block
, &se
.pre
);
1944 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1945 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1946 integer_type_node
, se
.expr
,
1947 fold_convert(integer_type_node
, lbound
));
1948 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1950 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1952 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1954 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1955 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1956 tmp
= fold_convert (integer_type_node
, tmp
);
1957 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1958 integer_type_node
, extent
, tmp
);
1962 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1964 gfc_init_se (&se
, NULL
);
1965 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1966 gfc_add_block_to_block (block
, &se
.pre
);
1967 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1968 lbound
= fold_convert (integer_type_node
, lbound
);
1969 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1970 integer_type_node
, se
.expr
, lbound
);
1971 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1973 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1975 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1977 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1978 ubound
= fold_convert (integer_type_node
, ubound
);
1979 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1980 integer_type_node
, ubound
, lbound
);
1981 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1982 tmp
, integer_one_node
);
1983 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1984 integer_type_node
, extent
, tmp
);
1987 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1988 img_idx
, integer_one_node
);
1993 /* For each character array constructor subexpression without a ts.u.cl->length,
1994 replace it by its first element (if there aren't any elements, the length
1995 should already be set to zero). */
1998 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2000 gfc_actual_arglist
* arg
;
2006 switch (e
->expr_type
)
2010 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2011 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2015 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2019 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2020 flatten_array_ctors_without_strlen (arg
->expr
);
2025 /* We've found what we're looking for. */
2026 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2031 gcc_assert (e
->value
.constructor
);
2033 c
= gfc_constructor_first (e
->value
.constructor
);
2037 flatten_array_ctors_without_strlen (new_expr
);
2038 gfc_replace_expr (e
, new_expr
);
2042 /* Otherwise, fall through to handle constructor elements. */
2043 case EXPR_STRUCTURE
:
2044 for (c
= gfc_constructor_first (e
->value
.constructor
);
2045 c
; c
= gfc_constructor_next (c
))
2046 flatten_array_ctors_without_strlen (c
->expr
);
2056 /* Generate code to initialize a string length variable. Returns the
2057 value. For array constructors, cl->length might be NULL and in this case,
2058 the first element of the constructor is needed. expr is the original
2059 expression so we can access it but can be NULL if this is not needed. */
2062 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2066 gfc_init_se (&se
, NULL
);
2070 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2073 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2074 "flatten" array constructors by taking their first element; all elements
2075 should be the same length or a cl->length should be present. */
2078 gfc_expr
* expr_flat
;
2080 expr_flat
= gfc_copy_expr (expr
);
2081 flatten_array_ctors_without_strlen (expr_flat
);
2082 gfc_resolve_expr (expr_flat
);
2084 gfc_conv_expr (&se
, expr_flat
);
2085 gfc_add_block_to_block (pblock
, &se
.pre
);
2086 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2088 gfc_free_expr (expr_flat
);
2092 /* Convert cl->length. */
2094 gcc_assert (cl
->length
);
2096 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2097 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2098 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2099 gfc_add_block_to_block (pblock
, &se
.pre
);
2101 if (cl
->backend_decl
)
2102 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2104 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2109 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2110 const char *name
, locus
*where
)
2120 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2121 type
= build_pointer_type (type
);
2123 gfc_init_se (&start
, se
);
2124 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2125 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2127 if (integer_onep (start
.expr
))
2128 gfc_conv_string_parameter (se
);
2133 /* Avoid multiple evaluation of substring start. */
2134 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2135 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2137 /* Change the start of the string. */
2138 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2141 tmp
= build_fold_indirect_ref_loc (input_location
,
2143 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2144 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2147 /* Length = end + 1 - start. */
2148 gfc_init_se (&end
, se
);
2149 if (ref
->u
.ss
.end
== NULL
)
2150 end
.expr
= se
->string_length
;
2153 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2154 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2158 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2159 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2161 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2163 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2164 boolean_type_node
, start
.expr
,
2167 /* Check lower bound. */
2168 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2170 build_int_cst (gfc_charlen_type_node
, 1));
2171 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2172 boolean_type_node
, nonempty
, fault
);
2174 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2175 "is less than one", name
);
2177 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2178 "is less than one");
2179 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2180 fold_convert (long_integer_type_node
,
2184 /* Check upper bound. */
2185 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2186 end
.expr
, se
->string_length
);
2187 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2188 boolean_type_node
, nonempty
, fault
);
2190 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2191 "exceeds string length (%%ld)", name
);
2193 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2194 "exceeds string length (%%ld)");
2195 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2196 fold_convert (long_integer_type_node
, end
.expr
),
2197 fold_convert (long_integer_type_node
,
2198 se
->string_length
));
2202 /* Try to calculate the length from the start and end expressions. */
2204 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2208 i_len
= mpz_get_si (length
) + 1;
2212 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2213 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2217 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2218 end
.expr
, start
.expr
);
2219 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2220 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2221 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2222 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2225 se
->string_length
= tmp
;
2229 /* Convert a derived type component reference. */
2232 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2239 c
= ref
->u
.c
.component
;
2241 if (c
->backend_decl
== NULL_TREE
2242 && ref
->u
.c
.sym
!= NULL
)
2243 gfc_get_derived_type (ref
->u
.c
.sym
);
2245 field
= c
->backend_decl
;
2246 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2249 /* Components can correspond to fields of different containing
2250 types, as components are created without context, whereas
2251 a concrete use of a component has the type of decl as context.
2252 So, if the type doesn't match, we search the corresponding
2253 FIELD_DECL in the parent type. To not waste too much time
2254 we cache this result in norestrict_decl. */
2256 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2258 tree f2
= c
->norestrict_decl
;
2259 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2260 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2261 if (TREE_CODE (f2
) == FIELD_DECL
2262 && DECL_NAME (f2
) == DECL_NAME (field
))
2265 c
->norestrict_decl
= f2
;
2269 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2270 && strcmp ("_data", c
->name
) == 0)
2272 /* Found a ref to the _data component. Store the associated ref to
2273 the vptr in se->class_vptr. */
2274 se
->class_vptr
= gfc_class_vptr_get (decl
);
2277 se
->class_vptr
= NULL_TREE
;
2279 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2280 decl
, field
, NULL_TREE
);
2284 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2285 strlen () conditional below. */
2286 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2287 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2289 tmp
= c
->ts
.u
.cl
->backend_decl
;
2290 /* Components must always be constant length. */
2291 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2292 se
->string_length
= tmp
;
2295 if (gfc_deferred_strlen (c
, &field
))
2297 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2299 decl
, field
, NULL_TREE
);
2300 se
->string_length
= tmp
;
2303 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2304 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2305 && c
->ts
.type
!= BT_CHARACTER
)
2306 || c
->attr
.proc_pointer
)
2307 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2312 /* This function deals with component references to components of the
2313 parent type for derived type extensions. */
2315 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2323 c
= ref
->u
.c
.component
;
2325 /* Return if the component is in the parent type. */
2326 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2327 if (strcmp (c
->name
, cmp
->name
) == 0)
2330 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2331 parent
.type
= REF_COMPONENT
;
2333 parent
.u
.c
.sym
= dt
;
2334 parent
.u
.c
.component
= dt
->components
;
2336 if (dt
->backend_decl
== NULL
)
2337 gfc_get_derived_type (dt
);
2339 /* Build the reference and call self. */
2340 gfc_conv_component_ref (se
, &parent
);
2341 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2342 parent
.u
.c
.component
= c
;
2343 conv_parent_component_references (se
, &parent
);
2346 /* Return the contents of a variable. Also handles reference/pointer
2347 variables (all Fortran pointer references are implicit). */
2350 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2355 tree parent_decl
= NULL_TREE
;
2358 bool alternate_entry
;
2361 bool first_time
= true;
2363 sym
= expr
->symtree
->n
.sym
;
2364 is_classarray
= IS_CLASS_ARRAY (sym
);
2368 gfc_ss_info
*ss_info
= ss
->info
;
2370 /* Check that something hasn't gone horribly wrong. */
2371 gcc_assert (ss
!= gfc_ss_terminator
);
2372 gcc_assert (ss_info
->expr
== expr
);
2374 /* A scalarized term. We already know the descriptor. */
2375 se
->expr
= ss_info
->data
.array
.descriptor
;
2376 se
->string_length
= ss_info
->string_length
;
2377 ref
= ss_info
->data
.array
.ref
;
2379 gcc_assert (ref
->type
== REF_ARRAY
2380 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2382 gfc_conv_tmp_array_ref (se
);
2386 tree se_expr
= NULL_TREE
;
2388 se
->expr
= gfc_get_symbol_decl (sym
);
2390 /* Deal with references to a parent results or entries by storing
2391 the current_function_decl and moving to the parent_decl. */
2392 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2393 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2394 && sym
->result
== sym
;
2395 entry_master
= sym
->attr
.result
2396 && sym
->ns
->proc_name
->attr
.entry_master
2397 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2398 if (current_function_decl
)
2399 parent_decl
= DECL_CONTEXT (current_function_decl
);
2401 if ((se
->expr
== parent_decl
&& return_value
)
2402 || (sym
->ns
&& sym
->ns
->proc_name
2404 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2405 && (alternate_entry
|| entry_master
)))
2410 /* Special case for assigning the return value of a function.
2411 Self recursive functions must have an explicit return value. */
2412 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2413 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2415 /* Similarly for alternate entry points. */
2416 else if (alternate_entry
2417 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2420 gfc_entry_list
*el
= NULL
;
2422 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2425 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2430 else if (entry_master
2431 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2433 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2438 /* Procedure actual arguments. */
2439 else if (sym
->attr
.flavor
== FL_PROCEDURE
2440 && se
->expr
!= current_function_decl
)
2442 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2444 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2445 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2451 /* Dereference the expression, where needed. Since characters
2452 are entirely different from other types, they are treated
2454 if (sym
->ts
.type
== BT_CHARACTER
)
2456 /* Dereference character pointer dummy arguments
2458 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2460 || sym
->attr
.function
2461 || sym
->attr
.result
))
2462 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2466 else if (!sym
->attr
.value
)
2468 /* Dereference temporaries for class array dummy arguments. */
2469 if (sym
->attr
.dummy
&& is_classarray
2470 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2472 if (!se
->descriptor_only
)
2473 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2475 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2479 /* Dereference non-character scalar dummy arguments. */
2480 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2481 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2482 && (sym
->ts
.type
!= BT_CLASS
2483 || (!CLASS_DATA (sym
)->attr
.dimension
2484 && !(CLASS_DATA (sym
)->attr
.codimension
2485 && CLASS_DATA (sym
)->attr
.allocatable
))))
2486 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2489 /* Dereference scalar hidden result. */
2490 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2491 && (sym
->attr
.function
|| sym
->attr
.result
)
2492 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2493 && !sym
->attr
.always_explicit
)
2494 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2497 /* Dereference non-character, non-class pointer variables.
2498 These must be dummies, results, or scalars. */
2500 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2501 || gfc_is_associate_pointer (sym
)
2502 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2504 || sym
->attr
.function
2506 || (!sym
->attr
.dimension
2507 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2508 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2510 /* Now treat the class array pointer variables accordingly. */
2511 else if (sym
->ts
.type
== BT_CLASS
2513 && (CLASS_DATA (sym
)->attr
.dimension
2514 || CLASS_DATA (sym
)->attr
.codimension
)
2515 && ((CLASS_DATA (sym
)->as
2516 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2517 || CLASS_DATA (sym
)->attr
.allocatable
2518 || CLASS_DATA (sym
)->attr
.class_pointer
))
2519 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2521 /* And the case where a non-dummy, non-result, non-function,
2522 non-allotable and non-pointer classarray is present. This case was
2523 previously covered by the first if, but with introducing the
2524 condition !is_classarray there, that case has to be covered
2526 else if (sym
->ts
.type
== BT_CLASS
2528 && !sym
->attr
.function
2529 && !sym
->attr
.result
2530 && (CLASS_DATA (sym
)->attr
.dimension
2531 || CLASS_DATA (sym
)->attr
.codimension
)
2532 && !CLASS_DATA (sym
)->attr
.allocatable
2533 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2534 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2541 /* For character variables, also get the length. */
2542 if (sym
->ts
.type
== BT_CHARACTER
)
2544 /* If the character length of an entry isn't set, get the length from
2545 the master function instead. */
2546 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2547 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2549 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2550 gcc_assert (se
->string_length
);
2558 /* Return the descriptor if that's what we want and this is an array
2559 section reference. */
2560 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2562 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2563 /* Return the descriptor for array pointers and allocations. */
2564 if (se
->want_pointer
2565 && ref
->next
== NULL
&& (se
->descriptor_only
))
2568 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2569 /* Return a pointer to an element. */
2573 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2574 && se
->descriptor_only
2575 && !CLASS_DATA (sym
)->attr
.allocatable
2576 && !CLASS_DATA (sym
)->attr
.class_pointer
2577 && CLASS_DATA (sym
)->as
2578 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2579 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2580 /* Skip the first ref of a _data component, because for class
2581 arrays that one is already done by introducing a temporary
2582 array descriptor. */
2585 if (ref
->u
.c
.sym
->attr
.extension
)
2586 conv_parent_component_references (se
, ref
);
2588 gfc_conv_component_ref (se
, ref
);
2589 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2590 && se
->want_pointer
&& se
->descriptor_only
)
2596 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2597 expr
->symtree
->name
, &expr
->where
);
2607 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2609 if (se
->want_pointer
)
2611 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2612 gfc_conv_string_parameter (se
);
2614 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2619 /* Unary ops are easy... Or they would be if ! was a valid op. */
2622 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2627 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2628 /* Initialize the operand. */
2629 gfc_init_se (&operand
, se
);
2630 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2631 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2633 type
= gfc_typenode_for_spec (&expr
->ts
);
2635 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2636 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2637 All other unary operators have an equivalent GIMPLE unary operator. */
2638 if (code
== TRUTH_NOT_EXPR
)
2639 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2640 build_int_cst (type
, 0));
2642 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2646 /* Expand power operator to optimal multiplications when a value is raised
2647 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2648 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2649 Programming", 3rd Edition, 1998. */
2651 /* This code is mostly duplicated from expand_powi in the backend.
2652 We establish the "optimal power tree" lookup table with the defined size.
2653 The items in the table are the exponents used to calculate the index
2654 exponents. Any integer n less than the value can get an "addition chain",
2655 with the first node being one. */
2656 #define POWI_TABLE_SIZE 256
2658 /* The table is from builtins.c. */
2659 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2661 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2662 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2663 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2664 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2665 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2666 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2667 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2668 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2669 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2670 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2671 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2672 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2673 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2674 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2675 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2676 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2677 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2678 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2679 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2680 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2681 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2682 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2683 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2684 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2685 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2686 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2687 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2688 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2689 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2690 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2691 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2692 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2695 /* If n is larger than lookup table's max index, we use the "window
2697 #define POWI_WINDOW_SIZE 3
2699 /* Recursive function to expand the power operator. The temporary
2700 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2702 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2709 if (n
< POWI_TABLE_SIZE
)
2714 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2715 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2719 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2720 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2721 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2725 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2729 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2730 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2732 if (n
< POWI_TABLE_SIZE
)
2739 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2740 return 1. Else return 0 and a call to runtime library functions
2741 will have to be built. */
2743 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2748 tree vartmp
[POWI_TABLE_SIZE
];
2750 unsigned HOST_WIDE_INT n
;
2752 wide_int wrhs
= rhs
;
2754 /* If exponent is too large, we won't expand it anyway, so don't bother
2755 with large integer values. */
2756 if (!wi::fits_shwi_p (wrhs
))
2759 m
= wrhs
.to_shwi ();
2760 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2761 of the asymmetric range of the integer type. */
2762 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2764 type
= TREE_TYPE (lhs
);
2765 sgn
= tree_int_cst_sgn (rhs
);
2767 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2768 || optimize_size
) && (m
> 2 || m
< -1))
2774 se
->expr
= gfc_build_const (type
, integer_one_node
);
2778 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2779 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2781 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2782 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2783 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2784 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2787 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2790 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2791 boolean_type_node
, tmp
, cond
);
2792 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2793 tmp
, build_int_cst (type
, 1),
2794 build_int_cst (type
, 0));
2798 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2799 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2800 build_int_cst (type
, -1),
2801 build_int_cst (type
, 0));
2802 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2803 cond
, build_int_cst (type
, 1), tmp
);
2807 memset (vartmp
, 0, sizeof (vartmp
));
2811 tmp
= gfc_build_const (type
, integer_one_node
);
2812 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2816 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2822 /* Power op (**). Constant integer exponent has special handling. */
2825 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2827 tree gfc_int4_type_node
;
2830 int res_ikind_1
, res_ikind_2
;
2835 gfc_init_se (&lse
, se
);
2836 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2837 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2838 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2840 gfc_init_se (&rse
, se
);
2841 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2842 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2844 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2845 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2846 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2849 gfc_int4_type_node
= gfc_get_int_type (4);
2851 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2852 library routine. But in the end, we have to convert the result back
2853 if this case applies -- with res_ikind_K, we keep track whether operand K
2854 falls into this case. */
2858 kind
= expr
->value
.op
.op1
->ts
.kind
;
2859 switch (expr
->value
.op
.op2
->ts
.type
)
2862 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2867 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2868 res_ikind_2
= ikind
;
2890 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2892 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2919 switch (expr
->value
.op
.op1
->ts
.type
)
2922 if (kind
== 3) /* Case 16 was not handled properly above. */
2924 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2928 /* Use builtins for real ** int4. */
2934 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2938 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2942 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2946 /* Use the __builtin_powil() only if real(kind=16) is
2947 actually the C long double type. */
2948 if (!gfc_real16_is_float128
)
2949 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2957 /* If we don't have a good builtin for this, go for the
2958 library function. */
2960 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2964 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2973 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2977 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2985 se
->expr
= build_call_expr_loc (input_location
,
2986 fndecl
, 2, lse
.expr
, rse
.expr
);
2988 /* Convert the result back if it is of wrong integer kind. */
2989 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2991 /* We want the maximum of both operand kinds as result. */
2992 if (res_ikind_1
< res_ikind_2
)
2993 res_ikind_1
= res_ikind_2
;
2994 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2999 /* Generate code to allocate a string temporary. */
3002 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3007 if (gfc_can_put_var_on_stack (len
))
3009 /* Create a temporary variable to hold the result. */
3010 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3011 gfc_charlen_type_node
, len
,
3012 build_int_cst (gfc_charlen_type_node
, 1));
3013 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3015 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3016 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3018 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3020 var
= gfc_create_var (tmp
, "str");
3021 var
= gfc_build_addr_expr (type
, var
);
3025 /* Allocate a temporary to hold the result. */
3026 var
= gfc_create_var (type
, "pstr");
3027 gcc_assert (POINTER_TYPE_P (type
));
3028 tmp
= TREE_TYPE (type
);
3029 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3030 tmp
= TREE_TYPE (tmp
);
3031 tmp
= TYPE_SIZE_UNIT (tmp
);
3032 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3033 fold_convert (size_type_node
, len
),
3034 fold_convert (size_type_node
, tmp
));
3035 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3036 gfc_add_modify (&se
->pre
, var
, tmp
);
3038 /* Free the temporary afterwards. */
3039 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
3040 gfc_add_expr_to_block (&se
->post
, tmp
);
3047 /* Handle a string concatenation operation. A temporary will be allocated to
3051 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3054 tree len
, type
, var
, tmp
, fndecl
;
3056 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3057 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3058 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3060 gfc_init_se (&lse
, se
);
3061 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3062 gfc_conv_string_parameter (&lse
);
3063 gfc_init_se (&rse
, se
);
3064 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3065 gfc_conv_string_parameter (&rse
);
3067 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3068 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3070 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3071 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3072 if (len
== NULL_TREE
)
3074 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3075 TREE_TYPE (lse
.string_length
),
3076 lse
.string_length
, rse
.string_length
);
3079 type
= build_pointer_type (type
);
3081 var
= gfc_conv_string_tmp (se
, type
, len
);
3083 /* Do the actual concatenation. */
3084 if (expr
->ts
.kind
== 1)
3085 fndecl
= gfor_fndecl_concat_string
;
3086 else if (expr
->ts
.kind
== 4)
3087 fndecl
= gfor_fndecl_concat_string_char4
;
3091 tmp
= build_call_expr_loc (input_location
,
3092 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3093 rse
.string_length
, rse
.expr
);
3094 gfc_add_expr_to_block (&se
->pre
, tmp
);
3096 /* Add the cleanup for the operands. */
3097 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3098 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3101 se
->string_length
= len
;
3104 /* Translates an op expression. Common (binary) cases are handled by this
3105 function, others are passed on. Recursion is used in either case.
3106 We use the fact that (op1.ts == op2.ts) (except for the power
3108 Operators need no special handling for scalarized expressions as long as
3109 they call gfc_conv_simple_val to get their operands.
3110 Character strings get special handling. */
3113 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3115 enum tree_code code
;
3124 switch (expr
->value
.op
.op
)
3126 case INTRINSIC_PARENTHESES
:
3127 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3128 && flag_protect_parens
)
3130 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3131 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3136 case INTRINSIC_UPLUS
:
3137 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3140 case INTRINSIC_UMINUS
:
3141 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3145 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3148 case INTRINSIC_PLUS
:
3152 case INTRINSIC_MINUS
:
3156 case INTRINSIC_TIMES
:
3160 case INTRINSIC_DIVIDE
:
3161 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3162 an integer, we must round towards zero, so we use a
3164 if (expr
->ts
.type
== BT_INTEGER
)
3165 code
= TRUNC_DIV_EXPR
;
3170 case INTRINSIC_POWER
:
3171 gfc_conv_power_op (se
, expr
);
3174 case INTRINSIC_CONCAT
:
3175 gfc_conv_concat_op (se
, expr
);
3179 code
= TRUTH_ANDIF_EXPR
;
3184 code
= TRUTH_ORIF_EXPR
;
3188 /* EQV and NEQV only work on logicals, but since we represent them
3189 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3191 case INTRINSIC_EQ_OS
:
3199 case INTRINSIC_NE_OS
:
3200 case INTRINSIC_NEQV
:
3207 case INTRINSIC_GT_OS
:
3214 case INTRINSIC_GE_OS
:
3221 case INTRINSIC_LT_OS
:
3228 case INTRINSIC_LE_OS
:
3234 case INTRINSIC_USER
:
3235 case INTRINSIC_ASSIGN
:
3236 /* These should be converted into function calls by the frontend. */
3240 fatal_error (input_location
, "Unknown intrinsic op");
3244 /* The only exception to this is **, which is handled separately anyway. */
3245 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3247 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3251 gfc_init_se (&lse
, se
);
3252 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3253 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3256 gfc_init_se (&rse
, se
);
3257 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3258 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3262 gfc_conv_string_parameter (&lse
);
3263 gfc_conv_string_parameter (&rse
);
3265 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3266 rse
.string_length
, rse
.expr
,
3267 expr
->value
.op
.op1
->ts
.kind
,
3269 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3270 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3273 type
= gfc_typenode_for_spec (&expr
->ts
);
3277 /* The result of logical ops is always boolean_type_node. */
3278 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3279 lse
.expr
, rse
.expr
);
3280 se
->expr
= convert (type
, tmp
);
3283 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3285 /* Add the post blocks. */
3286 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3287 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3290 /* If a string's length is one, we convert it to a single character. */
3293 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3297 || !tree_fits_uhwi_p (len
)
3298 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3301 if (TREE_INT_CST_LOW (len
) == 1)
3303 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3304 return build_fold_indirect_ref_loc (input_location
, str
);
3308 && TREE_CODE (str
) == ADDR_EXPR
3309 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3310 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3311 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3312 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3313 && TREE_INT_CST_LOW (len
) > 1
3314 && TREE_INT_CST_LOW (len
)
3315 == (unsigned HOST_WIDE_INT
)
3316 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3318 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3319 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3320 if (TREE_CODE (ret
) == INTEGER_CST
)
3322 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3323 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3324 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3326 for (i
= 1; i
< length
; i
++)
3339 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3342 if (sym
->backend_decl
)
3344 /* This becomes the nominal_type in
3345 function.c:assign_parm_find_data_types. */
3346 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3347 /* This becomes the passed_type in
3348 function.c:assign_parm_find_data_types. C promotes char to
3349 integer for argument passing. */
3350 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3352 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3357 /* If we have a constant character expression, make it into an
3359 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3364 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3365 (int)(*expr
)->value
.character
.string
[0]);
3366 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3368 /* The expr needs to be compatible with a C int. If the
3369 conversion fails, then the 2 causes an ICE. */
3370 ts
.type
= BT_INTEGER
;
3371 ts
.kind
= gfc_c_int_kind
;
3372 gfc_convert_type (*expr
, &ts
, 2);
3375 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3377 if ((*expr
)->ref
== NULL
)
3379 se
->expr
= gfc_string_to_single_character
3380 (build_int_cst (integer_type_node
, 1),
3381 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3383 ((*expr
)->symtree
->n
.sym
)),
3388 gfc_conv_variable (se
, *expr
);
3389 se
->expr
= gfc_string_to_single_character
3390 (build_int_cst (integer_type_node
, 1),
3391 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3399 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3400 if STR is a string literal, otherwise return -1. */
3403 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3406 && TREE_CODE (str
) == ADDR_EXPR
3407 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3408 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3409 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3410 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3411 && tree_fits_uhwi_p (len
)
3412 && tree_to_uhwi (len
) >= 1
3413 && tree_to_uhwi (len
)
3414 == (unsigned HOST_WIDE_INT
)
3415 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3417 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3418 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3419 if (TREE_CODE (folded
) == INTEGER_CST
)
3421 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3422 int length
= TREE_STRING_LENGTH (string_cst
);
3423 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3425 for (; length
> 0; length
--)
3426 if (ptr
[length
- 1] != ' ')
3435 /* Helper to build a call to memcmp. */
3438 build_memcmp_call (tree s1
, tree s2
, tree n
)
3442 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3443 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3445 s1
= fold_convert (pvoid_type_node
, s1
);
3447 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3448 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3450 s2
= fold_convert (pvoid_type_node
, s2
);
3452 n
= fold_convert (size_type_node
, n
);
3454 tmp
= build_call_expr_loc (input_location
,
3455 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3458 return fold_convert (integer_type_node
, tmp
);
3461 /* Compare two strings. If they are all single characters, the result is the
3462 subtraction of them. Otherwise, we build a library call. */
3465 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3466 enum tree_code code
)
3472 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3473 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3475 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3476 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3478 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3480 /* Deal with single character specially. */
3481 sc1
= fold_convert (integer_type_node
, sc1
);
3482 sc2
= fold_convert (integer_type_node
, sc2
);
3483 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3487 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3489 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3491 /* If one string is a string literal with LEN_TRIM longer
3492 than the length of the second string, the strings
3494 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3495 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3496 return integer_one_node
;
3497 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3498 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3499 return integer_one_node
;
3502 /* We can compare via memcpy if the strings are known to be equal
3503 in length and they are
3505 - kind=4 and the comparison is for (in)equality. */
3507 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3508 && tree_int_cst_equal (len1
, len2
)
3509 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3514 chartype
= gfc_get_char_type (kind
);
3515 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3516 fold_convert (TREE_TYPE(len1
),
3517 TYPE_SIZE_UNIT(chartype
)),
3519 return build_memcmp_call (str1
, str2
, tmp
);
3522 /* Build a call for the comparison. */
3524 fndecl
= gfor_fndecl_compare_string
;
3526 fndecl
= gfor_fndecl_compare_string_char4
;
3530 return build_call_expr_loc (input_location
, fndecl
, 4,
3531 len1
, str1
, len2
, str2
);
3535 /* Return the backend_decl for a procedure pointer component. */
3538 get_proc_ptr_comp (gfc_expr
*e
)
3544 gfc_init_se (&comp_se
, NULL
);
3545 e2
= gfc_copy_expr (e
);
3546 /* We have to restore the expr type later so that gfc_free_expr frees
3547 the exact same thing that was allocated.
3548 TODO: This is ugly. */
3549 old_type
= e2
->expr_type
;
3550 e2
->expr_type
= EXPR_VARIABLE
;
3551 gfc_conv_expr (&comp_se
, e2
);
3552 e2
->expr_type
= old_type
;
3554 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3558 /* Convert a typebound function reference from a class object. */
3560 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3565 if (TREE_CODE (base_object
) != VAR_DECL
)
3567 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3568 gfc_add_modify (&se
->pre
, var
, base_object
);
3570 se
->expr
= gfc_class_vptr_get (base_object
);
3571 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3573 while (ref
&& ref
->next
)
3575 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3576 if (ref
->u
.c
.sym
->attr
.extension
)
3577 conv_parent_component_references (se
, ref
);
3578 gfc_conv_component_ref (se
, ref
);
3579 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3584 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3588 if (gfc_is_proc_ptr_comp (expr
))
3589 tmp
= get_proc_ptr_comp (expr
);
3590 else if (sym
->attr
.dummy
)
3592 tmp
= gfc_get_symbol_decl (sym
);
3593 if (sym
->attr
.proc_pointer
)
3594 tmp
= build_fold_indirect_ref_loc (input_location
,
3596 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3597 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3601 if (!sym
->backend_decl
)
3602 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3604 TREE_USED (sym
->backend_decl
) = 1;
3606 tmp
= sym
->backend_decl
;
3608 if (sym
->attr
.cray_pointee
)
3610 /* TODO - make the cray pointee a pointer to a procedure,
3611 assign the pointer to it and use it for the call. This
3613 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3614 gfc_get_symbol_decl (sym
->cp_pointer
));
3615 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3618 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3620 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3621 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3628 /* Initialize MAPPING. */
3631 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3633 mapping
->syms
= NULL
;
3634 mapping
->charlens
= NULL
;
3638 /* Free all memory held by MAPPING (but not MAPPING itself). */
3641 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3643 gfc_interface_sym_mapping
*sym
;
3644 gfc_interface_sym_mapping
*nextsym
;
3646 gfc_charlen
*nextcl
;
3648 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3650 nextsym
= sym
->next
;
3651 sym
->new_sym
->n
.sym
->formal
= NULL
;
3652 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3653 gfc_free_expr (sym
->expr
);
3654 free (sym
->new_sym
);
3657 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3660 gfc_free_expr (cl
->length
);
3666 /* Return a copy of gfc_charlen CL. Add the returned structure to
3667 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3669 static gfc_charlen
*
3670 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3673 gfc_charlen
*new_charlen
;
3675 new_charlen
= gfc_get_charlen ();
3676 new_charlen
->next
= mapping
->charlens
;
3677 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3679 mapping
->charlens
= new_charlen
;
3684 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3685 array variable that can be used as the actual argument for dummy
3686 argument SYM. Add any initialization code to BLOCK. PACKED is as
3687 for gfc_get_nodesc_array_type and DATA points to the first element
3688 in the passed array. */
3691 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3692 gfc_packed packed
, tree data
)
3697 type
= gfc_typenode_for_spec (&sym
->ts
);
3698 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3699 !sym
->attr
.target
&& !sym
->attr
.pointer
3700 && !sym
->attr
.proc_pointer
);
3702 var
= gfc_create_var (type
, "ifm");
3703 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3709 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3710 and offset of descriptorless array type TYPE given that it has the same
3711 size as DESC. Add any set-up code to BLOCK. */
3714 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3721 offset
= gfc_index_zero_node
;
3722 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3724 dim
= gfc_rank_cst
[n
];
3725 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3726 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3728 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3729 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3730 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3731 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3733 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3735 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3736 gfc_array_index_type
,
3737 gfc_conv_descriptor_ubound_get (desc
, dim
),
3738 gfc_conv_descriptor_lbound_get (desc
, dim
));
3739 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3740 gfc_array_index_type
,
3741 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3742 tmp
= gfc_evaluate_now (tmp
, block
);
3743 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3745 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3746 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3747 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3748 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3749 gfc_array_index_type
, offset
, tmp
);
3751 offset
= gfc_evaluate_now (offset
, block
);
3752 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3756 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3757 in SE. The caller may still use se->expr and se->string_length after
3758 calling this function. */
3761 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3762 gfc_symbol
* sym
, gfc_se
* se
,
3765 gfc_interface_sym_mapping
*sm
;
3769 gfc_symbol
*new_sym
;
3771 gfc_symtree
*new_symtree
;
3773 /* Create a new symbol to represent the actual argument. */
3774 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3775 new_sym
->ts
= sym
->ts
;
3776 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3777 new_sym
->attr
.referenced
= 1;
3778 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3779 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3780 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3781 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3782 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3783 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3784 new_sym
->attr
.function
= sym
->attr
.function
;
3786 /* Ensure that the interface is available and that
3787 descriptors are passed for array actual arguments. */
3788 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3790 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3791 new_sym
->attr
.always_explicit
3792 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3795 /* Create a fake symtree for it. */
3797 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3798 new_symtree
->n
.sym
= new_sym
;
3799 gcc_assert (new_symtree
== root
);
3801 /* Create a dummy->actual mapping. */
3802 sm
= XCNEW (gfc_interface_sym_mapping
);
3803 sm
->next
= mapping
->syms
;
3805 sm
->new_sym
= new_symtree
;
3806 sm
->expr
= gfc_copy_expr (expr
);
3809 /* Stabilize the argument's value. */
3810 if (!sym
->attr
.function
&& se
)
3811 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3813 if (sym
->ts
.type
== BT_CHARACTER
)
3815 /* Create a copy of the dummy argument's length. */
3816 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3817 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3819 /* If the length is specified as "*", record the length that
3820 the caller is passing. We should use the callee's length
3821 in all other cases. */
3822 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3824 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3825 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3832 /* Use the passed value as-is if the argument is a function. */
3833 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3836 /* If the argument is either a string or a pointer to a string,
3837 convert it to a boundless character type. */
3838 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3840 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3841 tmp
= build_pointer_type (tmp
);
3842 if (sym
->attr
.pointer
)
3843 value
= build_fold_indirect_ref_loc (input_location
,
3847 value
= fold_convert (tmp
, value
);
3850 /* If the argument is a scalar, a pointer to an array or an allocatable,
3852 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3853 value
= build_fold_indirect_ref_loc (input_location
,
3856 /* For character(*), use the actual argument's descriptor. */
3857 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3858 value
= build_fold_indirect_ref_loc (input_location
,
3861 /* If the argument is an array descriptor, use it to determine
3862 information about the actual argument's shape. */
3863 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3864 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3866 /* Get the actual argument's descriptor. */
3867 desc
= build_fold_indirect_ref_loc (input_location
,
3870 /* Create the replacement variable. */
3871 tmp
= gfc_conv_descriptor_data_get (desc
);
3872 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3875 /* Use DESC to work out the upper bounds, strides and offset. */
3876 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3879 /* Otherwise we have a packed array. */
3880 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3881 PACKED_FULL
, se
->expr
);
3883 new_sym
->backend_decl
= value
;
3887 /* Called once all dummy argument mappings have been added to MAPPING,
3888 but before the mapping is used to evaluate expressions. Pre-evaluate
3889 the length of each argument, adding any initialization code to PRE and
3890 any finalization code to POST. */
3893 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3894 stmtblock_t
* pre
, stmtblock_t
* post
)
3896 gfc_interface_sym_mapping
*sym
;
3900 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3901 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3902 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3904 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3905 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3906 gfc_init_se (&se
, NULL
);
3907 gfc_conv_expr (&se
, expr
);
3908 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3909 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3910 gfc_add_block_to_block (pre
, &se
.pre
);
3911 gfc_add_block_to_block (post
, &se
.post
);
3913 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3918 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3922 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3923 gfc_constructor_base base
)
3926 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3928 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3931 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3932 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3933 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3939 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3943 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3948 for (; ref
; ref
= ref
->next
)
3952 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3954 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3955 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3956 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3964 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3965 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3971 /* Convert intrinsic function calls into result expressions. */
3974 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3982 arg1
= expr
->value
.function
.actual
->expr
;
3983 if (expr
->value
.function
.actual
->next
)
3984 arg2
= expr
->value
.function
.actual
->next
->expr
;
3988 sym
= arg1
->symtree
->n
.sym
;
3990 if (sym
->attr
.dummy
)
3995 switch (expr
->value
.function
.isym
->id
)
3998 /* TODO figure out why this condition is necessary. */
3999 if (sym
->attr
.function
4000 && (arg1
->ts
.u
.cl
->length
== NULL
4001 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4002 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4005 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4009 if (!sym
->as
|| sym
->as
->rank
== 0)
4012 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4014 dup
= mpz_get_si (arg2
->value
.integer
);
4019 dup
= sym
->as
->rank
;
4023 for (; d
< dup
; d
++)
4027 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4029 gfc_free_expr (new_expr
);
4033 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4034 gfc_get_int_expr (gfc_default_integer_kind
,
4036 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4038 new_expr
= gfc_multiply (new_expr
, tmp
);
4044 case GFC_ISYM_LBOUND
:
4045 case GFC_ISYM_UBOUND
:
4046 /* TODO These implementations of lbound and ubound do not limit if
4047 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4049 if (!sym
->as
|| sym
->as
->rank
== 0)
4052 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4053 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4055 /* TODO: If the need arises, this could produce an array of
4059 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4061 if (sym
->as
->lower
[d
])
4062 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4066 if (sym
->as
->upper
[d
])
4067 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4075 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4079 gfc_replace_expr (expr
, new_expr
);
4085 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4086 gfc_interface_mapping
* mapping
)
4088 gfc_formal_arglist
*f
;
4089 gfc_actual_arglist
*actual
;
4091 actual
= expr
->value
.function
.actual
;
4092 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4094 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4099 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4102 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4107 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4109 for (d
= 0; d
< as
->rank
; d
++)
4111 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4112 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4115 expr
->value
.function
.esym
->as
= as
;
4118 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4120 expr
->value
.function
.esym
->ts
.u
.cl
->length
4121 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4123 gfc_apply_interface_mapping_to_expr (mapping
,
4124 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4129 /* EXPR is a copy of an expression that appeared in the interface
4130 associated with MAPPING. Walk it recursively looking for references to
4131 dummy arguments that MAPPING maps to actual arguments. Replace each such
4132 reference with a reference to the associated actual argument. */
4135 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4138 gfc_interface_sym_mapping
*sym
;
4139 gfc_actual_arglist
*actual
;
4144 /* Copying an expression does not copy its length, so do that here. */
4145 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4147 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4148 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4151 /* Apply the mapping to any references. */
4152 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4154 /* ...and to the expression's symbol, if it has one. */
4155 /* TODO Find out why the condition on expr->symtree had to be moved into
4156 the loop rather than being outside it, as originally. */
4157 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4158 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4160 if (sym
->new_sym
->n
.sym
->backend_decl
)
4161 expr
->symtree
= sym
->new_sym
;
4163 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4166 /* ...and to subexpressions in expr->value. */
4167 switch (expr
->expr_type
)
4172 case EXPR_SUBSTRING
:
4176 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4177 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4181 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4182 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4184 if (expr
->value
.function
.esym
== NULL
4185 && expr
->value
.function
.isym
!= NULL
4186 && expr
->value
.function
.actual
->expr
->symtree
4187 && gfc_map_intrinsic_function (expr
, mapping
))
4190 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4191 if (sym
->old
== expr
->value
.function
.esym
)
4193 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4194 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4195 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4200 case EXPR_STRUCTURE
:
4201 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4214 /* Evaluate interface expression EXPR using MAPPING. Store the result
4218 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4219 gfc_se
* se
, gfc_expr
* expr
)
4221 expr
= gfc_copy_expr (expr
);
4222 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4223 gfc_conv_expr (se
, expr
);
4224 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4225 gfc_free_expr (expr
);
4229 /* Returns a reference to a temporary array into which a component of
4230 an actual argument derived type array is copied and then returned
4231 after the function call. */
4233 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4234 sym_intent intent
, bool formal_ptr
)
4242 gfc_array_info
*info
;
4252 gfc_init_se (&lse
, NULL
);
4253 gfc_init_se (&rse
, NULL
);
4255 /* Walk the argument expression. */
4256 rss
= gfc_walk_expr (expr
);
4258 gcc_assert (rss
!= gfc_ss_terminator
);
4260 /* Initialize the scalarizer. */
4261 gfc_init_loopinfo (&loop
);
4262 gfc_add_ss_to_loop (&loop
, rss
);
4264 /* Calculate the bounds of the scalarization. */
4265 gfc_conv_ss_startstride (&loop
);
4267 /* Build an ss for the temporary. */
4268 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4269 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4271 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4272 if (GFC_ARRAY_TYPE_P (base_type
)
4273 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4274 base_type
= gfc_get_element_type (base_type
);
4276 if (expr
->ts
.type
== BT_CLASS
)
4277 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4279 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4280 ? expr
->ts
.u
.cl
->backend_decl
4284 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4286 /* Associate the SS with the loop. */
4287 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4289 /* Setup the scalarizing loops. */
4290 gfc_conv_loop_setup (&loop
, &expr
->where
);
4292 /* Pass the temporary descriptor back to the caller. */
4293 info
= &loop
.temp_ss
->info
->data
.array
;
4294 parmse
->expr
= info
->descriptor
;
4296 /* Setup the gfc_se structures. */
4297 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4298 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4301 lse
.ss
= loop
.temp_ss
;
4302 gfc_mark_ss_chain_used (rss
, 1);
4303 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4305 /* Start the scalarized loop body. */
4306 gfc_start_scalarized_body (&loop
, &body
);
4308 /* Translate the expression. */
4309 gfc_conv_expr (&rse
, expr
);
4311 /* Reset the offset for the function call since the loop
4312 is zero based on the data pointer. Note that the temp
4313 comes first in the loop chain since it is added second. */
4314 if (gfc_is_alloc_class_array_function (expr
))
4316 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4317 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4318 gfc_index_zero_node
);
4321 gfc_conv_tmp_array_ref (&lse
);
4323 if (intent
!= INTENT_OUT
)
4325 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
4326 gfc_add_expr_to_block (&body
, tmp
);
4327 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4328 gfc_trans_scalarizing_loops (&loop
, &body
);
4332 /* Make sure that the temporary declaration survives by merging
4333 all the loop declarations into the current context. */
4334 for (n
= 0; n
< loop
.dimen
; n
++)
4336 gfc_merge_block_scope (&body
);
4337 body
= loop
.code
[loop
.order
[n
]];
4339 gfc_merge_block_scope (&body
);
4342 /* Add the post block after the second loop, so that any
4343 freeing of allocated memory is done at the right time. */
4344 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4346 /**********Copy the temporary back again.*********/
4348 gfc_init_se (&lse
, NULL
);
4349 gfc_init_se (&rse
, NULL
);
4351 /* Walk the argument expression. */
4352 lss
= gfc_walk_expr (expr
);
4353 rse
.ss
= loop
.temp_ss
;
4356 /* Initialize the scalarizer. */
4357 gfc_init_loopinfo (&loop2
);
4358 gfc_add_ss_to_loop (&loop2
, lss
);
4360 dimen
= rse
.ss
->dimen
;
4362 /* Skip the write-out loop for this case. */
4363 if (gfc_is_alloc_class_array_function (expr
))
4364 goto class_array_fcn
;
4366 /* Calculate the bounds of the scalarization. */
4367 gfc_conv_ss_startstride (&loop2
);
4369 /* Setup the scalarizing loops. */
4370 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4372 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4373 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4375 gfc_mark_ss_chain_used (lss
, 1);
4376 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4378 /* Declare the variable to hold the temporary offset and start the
4379 scalarized loop body. */
4380 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4381 gfc_start_scalarized_body (&loop2
, &body
);
4383 /* Build the offsets for the temporary from the loop variables. The
4384 temporary array has lbounds of zero and strides of one in all
4385 dimensions, so this is very simple. The offset is only computed
4386 outside the innermost loop, so the overall transfer could be
4387 optimized further. */
4388 info
= &rse
.ss
->info
->data
.array
;
4390 tmp_index
= gfc_index_zero_node
;
4391 for (n
= dimen
- 1; n
> 0; n
--)
4394 tmp
= rse
.loop
->loopvar
[n
];
4395 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4396 tmp
, rse
.loop
->from
[n
]);
4397 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4400 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4401 gfc_array_index_type
,
4402 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4403 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4404 gfc_array_index_type
,
4405 tmp_str
, gfc_index_one_node
);
4407 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4408 gfc_array_index_type
, tmp
, tmp_str
);
4411 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4412 gfc_array_index_type
,
4413 tmp_index
, rse
.loop
->from
[0]);
4414 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4416 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4417 gfc_array_index_type
,
4418 rse
.loop
->loopvar
[0], offset
);
4420 /* Now use the offset for the reference. */
4421 tmp
= build_fold_indirect_ref_loc (input_location
,
4423 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4425 if (expr
->ts
.type
== BT_CHARACTER
)
4426 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4428 gfc_conv_expr (&lse
, expr
);
4430 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4432 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4433 gfc_add_expr_to_block (&body
, tmp
);
4435 /* Generate the copying loops. */
4436 gfc_trans_scalarizing_loops (&loop2
, &body
);
4438 /* Wrap the whole thing up by adding the second loop to the post-block
4439 and following it by the post-block of the first loop. In this way,
4440 if the temporary needs freeing, it is done after use! */
4441 if (intent
!= INTENT_IN
)
4443 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4444 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4449 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4451 gfc_cleanup_loop (&loop
);
4452 gfc_cleanup_loop (&loop2
);
4454 /* Pass the string length to the argument expression. */
4455 if (expr
->ts
.type
== BT_CHARACTER
)
4456 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4458 /* Determine the offset for pointer formal arguments and set the
4462 size
= gfc_index_one_node
;
4463 offset
= gfc_index_zero_node
;
4464 for (n
= 0; n
< dimen
; n
++)
4466 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4468 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4469 gfc_array_index_type
, tmp
,
4470 gfc_index_one_node
);
4471 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4475 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4478 gfc_index_one_node
);
4479 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4480 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4481 gfc_array_index_type
,
4483 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4484 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4485 gfc_array_index_type
,
4486 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4487 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4488 gfc_array_index_type
,
4489 tmp
, gfc_index_one_node
);
4490 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4491 gfc_array_index_type
, size
, tmp
);
4494 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4498 /* We want either the address for the data or the address of the descriptor,
4499 depending on the mode of passing array arguments. */
4501 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4503 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4509 /* Generate the code for argument list functions. */
4512 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4514 /* Pass by value for g77 %VAL(arg), pass the address
4515 indirectly for %LOC, else by reference. Thus %REF
4516 is a "do-nothing" and %LOC is the same as an F95
4518 if (strncmp (name
, "%VAL", 4) == 0)
4519 gfc_conv_expr (se
, expr
);
4520 else if (strncmp (name
, "%LOC", 4) == 0)
4522 gfc_conv_expr_reference (se
, expr
);
4523 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4525 else if (strncmp (name
, "%REF", 4) == 0)
4526 gfc_conv_expr_reference (se
, expr
);
4528 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4532 /* Generate code for a procedure call. Note can return se->post != NULL.
4533 If se->direct_byref is set then se->expr contains the return parameter.
4534 Return nonzero, if the call has alternate specifiers.
4535 'expr' is only needed for procedure pointer components. */
4538 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4539 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4540 vec
<tree
, va_gc
> *append_args
)
4542 gfc_interface_mapping mapping
;
4543 vec
<tree
, va_gc
> *arglist
;
4544 vec
<tree
, va_gc
> *retargs
;
4548 gfc_array_info
*info
;
4555 vec
<tree
, va_gc
> *stringargs
;
4556 vec
<tree
, va_gc
> *optionalargs
;
4558 gfc_formal_arglist
*formal
;
4559 gfc_actual_arglist
*arg
;
4560 int has_alternate_specifier
= 0;
4561 bool need_interface_mapping
;
4569 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4570 gfc_component
*comp
= NULL
;
4577 optionalargs
= NULL
;
4582 comp
= gfc_get_proc_ptr_comp (expr
);
4586 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4588 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4589 if (se
->ss
->info
->useflags
)
4591 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4592 && sym
->result
->attr
.dimension
)
4593 || (comp
&& comp
->attr
.dimension
)
4594 || gfc_is_alloc_class_array_function (expr
));
4595 gcc_assert (se
->loop
!= NULL
);
4596 /* Access the previously obtained result. */
4597 gfc_conv_tmp_array_ref (se
);
4601 info
= &se
->ss
->info
->data
.array
;
4606 gfc_init_block (&post
);
4607 gfc_init_interface_mapping (&mapping
);
4610 formal
= gfc_sym_get_dummy_args (sym
);
4611 need_interface_mapping
= sym
->attr
.dimension
||
4612 (sym
->ts
.type
== BT_CHARACTER
4613 && sym
->ts
.u
.cl
->length
4614 && sym
->ts
.u
.cl
->length
->expr_type
4619 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4620 need_interface_mapping
= comp
->attr
.dimension
||
4621 (comp
->ts
.type
== BT_CHARACTER
4622 && comp
->ts
.u
.cl
->length
4623 && comp
->ts
.u
.cl
->length
->expr_type
4627 base_object
= NULL_TREE
;
4628 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4629 is the third and fourth argument to such a function call a value
4630 denoting the number of elements to copy (i.e., most of the time the
4631 length of a deferred length string). */
4632 ulim_copy
= formal
== NULL
&& UNLIMITED_POLY (sym
)
4633 && strcmp ("_copy", comp
->name
) == 0;
4635 /* Evaluate the arguments. */
4636 for (arg
= args
, argc
= 0; arg
!= NULL
;
4637 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4640 fsym
= formal
? formal
->sym
: NULL
;
4641 parm_kind
= MISSING
;
4643 /* Class array expressions are sometimes coming completely unadorned
4644 with either arrayspec or _data component. Correct that here.
4645 OOP-TODO: Move this to the frontend. */
4646 if (e
&& e
->expr_type
== EXPR_VARIABLE
4648 && e
->ts
.type
== BT_CLASS
4649 && (CLASS_DATA (e
)->attr
.codimension
4650 || CLASS_DATA (e
)->attr
.dimension
))
4652 gfc_typespec temp_ts
= e
->ts
;
4653 gfc_add_class_array_ref (e
);
4659 if (se
->ignore_optional
)
4661 /* Some intrinsics have already been resolved to the correct
4665 else if (arg
->label
)
4667 has_alternate_specifier
= 1;
4672 gfc_init_se (&parmse
, NULL
);
4674 /* For scalar arguments with VALUE attribute which are passed by
4675 value, pass "0" and a hidden argument gives the optional
4677 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4678 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4679 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4681 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4683 vec_safe_push (optionalargs
, boolean_false_node
);
4687 /* Pass a NULL pointer for an absent arg. */
4688 parmse
.expr
= null_pointer_node
;
4689 if (arg
->missing_arg_type
== BT_CHARACTER
)
4690 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4695 else if (arg
->expr
->expr_type
== EXPR_NULL
4696 && fsym
&& !fsym
->attr
.pointer
4697 && (fsym
->ts
.type
!= BT_CLASS
4698 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4700 /* Pass a NULL pointer to denote an absent arg. */
4701 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4702 && (fsym
->ts
.type
!= BT_CLASS
4703 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4704 gfc_init_se (&parmse
, NULL
);
4705 parmse
.expr
= null_pointer_node
;
4706 if (arg
->missing_arg_type
== BT_CHARACTER
)
4707 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4709 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4710 && e
->ts
.type
== BT_DERIVED
)
4712 /* The derived type needs to be converted to a temporary
4714 gfc_init_se (&parmse
, se
);
4715 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4717 && e
->expr_type
== EXPR_VARIABLE
4718 && e
->symtree
->n
.sym
->attr
.optional
,
4719 CLASS_DATA (fsym
)->attr
.class_pointer
4720 || CLASS_DATA (fsym
)->attr
.allocatable
);
4722 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4724 /* The intrinsic type needs to be converted to a temporary
4725 CLASS object for the unlimited polymorphic formal. */
4726 gfc_init_se (&parmse
, se
);
4727 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4729 else if (se
->ss
&& se
->ss
->info
->useflags
)
4735 /* An elemental function inside a scalarized loop. */
4736 gfc_init_se (&parmse
, se
);
4737 parm_kind
= ELEMENTAL
;
4739 /* When no fsym is present, ulim_copy is set and this is a third or
4740 fourth argument, use call-by-value instead of by reference to
4741 hand the length properties to the copy routine (i.e., most of the
4742 time this will be a call to a __copy_character_* routine where the
4743 third and fourth arguments are the lengths of a deferred length
4745 if ((fsym
&& fsym
->attr
.value
)
4746 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4747 gfc_conv_expr (&parmse
, e
);
4749 gfc_conv_expr_reference (&parmse
, e
);
4751 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4752 && e
->expr_type
== EXPR_FUNCTION
)
4753 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4756 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4757 && gfc_is_class_container_ref (e
))
4759 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4761 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4762 && e
->symtree
->n
.sym
->attr
.optional
)
4764 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4765 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4766 TREE_TYPE (parmse
.expr
),
4768 fold_convert (TREE_TYPE (parmse
.expr
),
4769 null_pointer_node
));
4773 /* If we are passing an absent array as optional dummy to an
4774 elemental procedure, make sure that we pass NULL when the data
4775 pointer is NULL. We need this extra conditional because of
4776 scalarization which passes arrays elements to the procedure,
4777 ignoring the fact that the array can be absent/unallocated/... */
4778 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4780 tree descriptor_data
;
4782 descriptor_data
= ss
->info
->data
.array
.data
;
4783 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4785 fold_convert (TREE_TYPE (descriptor_data
),
4786 null_pointer_node
));
4788 = fold_build3_loc (input_location
, COND_EXPR
,
4789 TREE_TYPE (parmse
.expr
),
4790 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4791 fold_convert (TREE_TYPE (parmse
.expr
),
4796 /* The scalarizer does not repackage the reference to a class
4797 array - instead it returns a pointer to the data element. */
4798 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4799 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4800 fsym
->attr
.intent
!= INTENT_IN
4801 && (CLASS_DATA (fsym
)->attr
.class_pointer
4802 || CLASS_DATA (fsym
)->attr
.allocatable
),
4804 && e
->expr_type
== EXPR_VARIABLE
4805 && e
->symtree
->n
.sym
->attr
.optional
,
4806 CLASS_DATA (fsym
)->attr
.class_pointer
4807 || CLASS_DATA (fsym
)->attr
.allocatable
);
4814 gfc_init_se (&parmse
, NULL
);
4816 /* Check whether the expression is a scalar or not; we cannot use
4817 e->rank as it can be nonzero for functions arguments. */
4818 argss
= gfc_walk_expr (e
);
4819 scalar
= argss
== gfc_ss_terminator
;
4821 gfc_free_ss_chain (argss
);
4823 /* Special handling for passing scalar polymorphic coarrays;
4824 otherwise one passes "class->_data.data" instead of "&class". */
4825 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4826 && fsym
&& fsym
->ts
.type
== BT_CLASS
4827 && CLASS_DATA (fsym
)->attr
.codimension
4828 && !CLASS_DATA (fsym
)->attr
.dimension
)
4830 gfc_add_class_array_ref (e
);
4831 parmse
.want_coarray
= 1;
4835 /* A scalar or transformational function. */
4838 if (e
->expr_type
== EXPR_VARIABLE
4839 && e
->symtree
->n
.sym
->attr
.cray_pointee
4840 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4842 /* The Cray pointer needs to be converted to a pointer to
4843 a type given by the expression. */
4844 gfc_conv_expr (&parmse
, e
);
4845 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4846 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4847 parmse
.expr
= convert (type
, tmp
);
4849 else if (fsym
&& fsym
->attr
.value
)
4851 if (fsym
->ts
.type
== BT_CHARACTER
4852 && fsym
->ts
.is_c_interop
4853 && fsym
->ns
->proc_name
!= NULL
4854 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4857 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4858 if (parmse
.expr
== NULL
)
4859 gfc_conv_expr (&parmse
, e
);
4863 gfc_conv_expr (&parmse
, e
);
4864 if (fsym
->attr
.optional
4865 && fsym
->ts
.type
!= BT_CLASS
4866 && fsym
->ts
.type
!= BT_DERIVED
)
4868 if (e
->expr_type
!= EXPR_VARIABLE
4869 || !e
->symtree
->n
.sym
->attr
.optional
4871 vec_safe_push (optionalargs
, boolean_true_node
);
4874 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4875 if (!e
->symtree
->n
.sym
->attr
.value
)
4877 = fold_build3_loc (input_location
, COND_EXPR
,
4878 TREE_TYPE (parmse
.expr
),
4880 fold_convert (TREE_TYPE (parmse
.expr
),
4881 integer_zero_node
));
4883 vec_safe_push (optionalargs
, tmp
);
4888 else if (arg
->name
&& arg
->name
[0] == '%')
4889 /* Argument list functions %VAL, %LOC and %REF are signalled
4890 through arg->name. */
4891 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4892 else if ((e
->expr_type
== EXPR_FUNCTION
)
4893 && ((e
->value
.function
.esym
4894 && e
->value
.function
.esym
->result
->attr
.pointer
)
4895 || (!e
->value
.function
.esym
4896 && e
->symtree
->n
.sym
->attr
.pointer
))
4897 && fsym
&& fsym
->attr
.target
)
4899 gfc_conv_expr (&parmse
, e
);
4900 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4902 else if (e
->expr_type
== EXPR_FUNCTION
4903 && e
->symtree
->n
.sym
->result
4904 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4905 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4907 /* Functions returning procedure pointers. */
4908 gfc_conv_expr (&parmse
, e
);
4909 if (fsym
&& fsym
->attr
.proc_pointer
)
4910 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4914 if (e
->ts
.type
== BT_CLASS
&& fsym
4915 && fsym
->ts
.type
== BT_CLASS
4916 && (!CLASS_DATA (fsym
)->as
4917 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4918 && CLASS_DATA (e
)->attr
.codimension
)
4920 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4921 gcc_assert (!CLASS_DATA (fsym
)->as
);
4922 gfc_add_class_array_ref (e
);
4923 parmse
.want_coarray
= 1;
4924 gfc_conv_expr_reference (&parmse
, e
);
4925 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4927 && e
->expr_type
== EXPR_VARIABLE
);
4929 else if (e
->ts
.type
== BT_CLASS
&& fsym
4930 && fsym
->ts
.type
== BT_CLASS
4931 && !CLASS_DATA (fsym
)->as
4932 && !CLASS_DATA (e
)->as
4933 && strcmp (fsym
->ts
.u
.derived
->name
,
4934 e
->ts
.u
.derived
->name
))
4936 type
= gfc_typenode_for_spec (&fsym
->ts
);
4937 var
= gfc_create_var (type
, fsym
->name
);
4938 gfc_conv_expr (&parmse
, e
);
4939 if (fsym
->attr
.optional
4940 && e
->expr_type
== EXPR_VARIABLE
4941 && e
->symtree
->n
.sym
->attr
.optional
)
4945 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4946 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4947 boolean_type_node
, tmp
,
4948 fold_convert (TREE_TYPE (tmp
),
4949 null_pointer_node
));
4950 gfc_start_block (&block
);
4951 gfc_add_modify (&block
, var
,
4952 fold_build1_loc (input_location
,
4954 type
, parmse
.expr
));
4955 gfc_add_expr_to_block (&parmse
.pre
,
4956 fold_build3_loc (input_location
,
4957 COND_EXPR
, void_type_node
,
4958 cond
, gfc_finish_block (&block
),
4959 build_empty_stmt (input_location
)));
4960 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4961 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4962 TREE_TYPE (parmse
.expr
),
4964 fold_convert (TREE_TYPE (parmse
.expr
),
4965 null_pointer_node
));
4969 gfc_add_modify (&parmse
.pre
, var
,
4970 fold_build1_loc (input_location
,
4972 type
, parmse
.expr
));
4973 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4977 gfc_conv_expr_reference (&parmse
, e
);
4979 /* Catch base objects that are not variables. */
4980 if (e
->ts
.type
== BT_CLASS
4981 && e
->expr_type
!= EXPR_VARIABLE
4982 && expr
&& e
== expr
->base_expr
)
4983 base_object
= build_fold_indirect_ref_loc (input_location
,
4986 /* A class array element needs converting back to be a
4987 class object, if the formal argument is a class object. */
4988 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4989 && e
->ts
.type
== BT_CLASS
4990 && ((CLASS_DATA (fsym
)->as
4991 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4992 || CLASS_DATA (e
)->attr
.dimension
))
4993 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4994 fsym
->attr
.intent
!= INTENT_IN
4995 && (CLASS_DATA (fsym
)->attr
.class_pointer
4996 || CLASS_DATA (fsym
)->attr
.allocatable
),
4998 && e
->expr_type
== EXPR_VARIABLE
4999 && e
->symtree
->n
.sym
->attr
.optional
,
5000 CLASS_DATA (fsym
)->attr
.class_pointer
5001 || CLASS_DATA (fsym
)->attr
.allocatable
);
5003 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5004 allocated on entry, it must be deallocated. */
5005 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5006 && (fsym
->attr
.allocatable
5007 || (fsym
->ts
.type
== BT_CLASS
5008 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5013 gfc_init_block (&block
);
5015 if (e
->ts
.type
== BT_CLASS
)
5016 ptr
= gfc_class_data_get (ptr
);
5018 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5020 gfc_add_expr_to_block (&block
, tmp
);
5021 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5022 void_type_node
, ptr
,
5024 gfc_add_expr_to_block (&block
, tmp
);
5026 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5028 gfc_add_modify (&block
, ptr
,
5029 fold_convert (TREE_TYPE (ptr
),
5030 null_pointer_node
));
5031 gfc_add_expr_to_block (&block
, tmp
);
5033 else if (fsym
->ts
.type
== BT_CLASS
)
5036 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5037 tmp
= gfc_get_symbol_decl (vtab
);
5038 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5039 ptr
= gfc_class_vptr_get (parmse
.expr
);
5040 gfc_add_modify (&block
, ptr
,
5041 fold_convert (TREE_TYPE (ptr
), tmp
));
5042 gfc_add_expr_to_block (&block
, tmp
);
5045 if (fsym
->attr
.optional
5046 && e
->expr_type
== EXPR_VARIABLE
5047 && e
->symtree
->n
.sym
->attr
.optional
)
5049 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5051 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5052 gfc_finish_block (&block
),
5053 build_empty_stmt (input_location
));
5056 tmp
= gfc_finish_block (&block
);
5058 gfc_add_expr_to_block (&se
->pre
, tmp
);
5061 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5062 || fsym
->ts
.type
== BT_ASSUMED
)
5063 && e
->ts
.type
== BT_CLASS
5064 && !CLASS_DATA (e
)->attr
.dimension
5065 && !CLASS_DATA (e
)->attr
.codimension
)
5066 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5068 /* Wrap scalar variable in a descriptor. We need to convert
5069 the address of a pointer back to the pointer itself before,
5070 we can assign it to the data field. */
5072 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5073 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5076 if (TREE_CODE (tmp
) == ADDR_EXPR
5077 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5078 tmp
= TREE_OPERAND (tmp
, 0);
5079 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5081 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5084 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5085 && ((fsym
->attr
.pointer
5086 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5087 || (fsym
->attr
.proc_pointer
5088 && !(e
->expr_type
== EXPR_VARIABLE
5089 && e
->symtree
->n
.sym
->attr
.dummy
))
5090 || (fsym
->attr
.proc_pointer
5091 && e
->expr_type
== EXPR_VARIABLE
5092 && gfc_is_proc_ptr_comp (e
))
5093 || (fsym
->attr
.allocatable
5094 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5096 /* Scalar pointer dummy args require an extra level of
5097 indirection. The null pointer already contains
5098 this level of indirection. */
5099 parm_kind
= SCALAR_POINTER
;
5100 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5104 else if (e
->ts
.type
== BT_CLASS
5105 && fsym
&& fsym
->ts
.type
== BT_CLASS
5106 && (CLASS_DATA (fsym
)->attr
.dimension
5107 || CLASS_DATA (fsym
)->attr
.codimension
))
5109 /* Pass a class array. */
5110 parmse
.use_offset
= 1;
5111 gfc_conv_expr_descriptor (&parmse
, e
);
5113 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5114 allocated on entry, it must be deallocated. */
5115 if (fsym
->attr
.intent
== INTENT_OUT
5116 && CLASS_DATA (fsym
)->attr
.allocatable
)
5121 gfc_init_block (&block
);
5123 ptr
= gfc_class_data_get (ptr
);
5125 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5126 NULL_TREE
, NULL_TREE
,
5129 gfc_add_expr_to_block (&block
, tmp
);
5130 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5131 void_type_node
, ptr
,
5133 gfc_add_expr_to_block (&block
, tmp
);
5134 gfc_reset_vptr (&block
, e
);
5136 if (fsym
->attr
.optional
5137 && e
->expr_type
== EXPR_VARIABLE
5139 || (e
->ref
->type
== REF_ARRAY
5140 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5141 && e
->symtree
->n
.sym
->attr
.optional
)
5143 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5145 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5146 gfc_finish_block (&block
),
5147 build_empty_stmt (input_location
));
5150 tmp
= gfc_finish_block (&block
);
5152 gfc_add_expr_to_block (&se
->pre
, tmp
);
5155 /* The conversion does not repackage the reference to a class
5156 array - _data descriptor. */
5157 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5158 fsym
->attr
.intent
!= INTENT_IN
5159 && (CLASS_DATA (fsym
)->attr
.class_pointer
5160 || CLASS_DATA (fsym
)->attr
.allocatable
),
5162 && e
->expr_type
== EXPR_VARIABLE
5163 && e
->symtree
->n
.sym
->attr
.optional
,
5164 CLASS_DATA (fsym
)->attr
.class_pointer
5165 || CLASS_DATA (fsym
)->attr
.allocatable
);
5169 /* If the procedure requires an explicit interface, the actual
5170 argument is passed according to the corresponding formal
5171 argument. If the corresponding formal argument is a POINTER,
5172 ALLOCATABLE or assumed shape, we do not use g77's calling
5173 convention, and pass the address of the array descriptor
5174 instead. Otherwise we use g77's calling convention. */
5177 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5178 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
5179 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5181 f
= f
|| !comp
->attr
.always_explicit
;
5183 f
= f
|| !sym
->attr
.always_explicit
;
5185 /* If the argument is a function call that may not create
5186 a temporary for the result, we have to check that we
5187 can do it, i.e. that there is no alias between this
5188 argument and another one. */
5189 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5195 intent
= fsym
->attr
.intent
;
5197 intent
= INTENT_UNKNOWN
;
5199 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5201 parmse
.force_tmp
= 1;
5203 iarg
= e
->value
.function
.actual
->expr
;
5205 /* Temporary needed if aliasing due to host association. */
5206 if (sym
->attr
.contained
5208 && !sym
->attr
.implicit_pure
5209 && !sym
->attr
.use_assoc
5210 && iarg
->expr_type
== EXPR_VARIABLE
5211 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5212 parmse
.force_tmp
= 1;
5214 /* Ditto within module. */
5215 if (sym
->attr
.use_assoc
5217 && !sym
->attr
.implicit_pure
5218 && iarg
->expr_type
== EXPR_VARIABLE
5219 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5220 parmse
.force_tmp
= 1;
5223 if (e
->expr_type
== EXPR_VARIABLE
5224 && is_subref_array (e
))
5225 /* The actual argument is a component reference to an
5226 array of derived types. In this case, the argument
5227 is converted to a temporary, which is passed and then
5228 written back after the procedure call. */
5229 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5230 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5231 fsym
&& fsym
->attr
.pointer
);
5232 else if (gfc_is_class_array_ref (e
, NULL
)
5233 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5234 /* The actual argument is a component reference to an
5235 array of derived types. In this case, the argument
5236 is converted to a temporary, which is passed and then
5237 written back after the procedure call.
5238 OOP-TODO: Insert code so that if the dynamic type is
5239 the same as the declared type, copy-in/copy-out does
5241 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5242 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5243 fsym
&& fsym
->attr
.pointer
);
5245 else if (gfc_is_alloc_class_array_function (e
)
5246 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5247 /* See previous comment. For function actual argument,
5248 the write out is not needed so the intent is set as
5251 e
->must_finalize
= 1;
5252 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5254 fsym
&& fsym
->attr
.pointer
);
5257 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
5259 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5260 allocated on entry, it must be deallocated. */
5261 if (fsym
&& fsym
->attr
.allocatable
5262 && fsym
->attr
.intent
== INTENT_OUT
)
5264 tmp
= build_fold_indirect_ref_loc (input_location
,
5266 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5267 if (fsym
->attr
.optional
5268 && e
->expr_type
== EXPR_VARIABLE
5269 && e
->symtree
->n
.sym
->attr
.optional
)
5270 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5272 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5273 tmp
, build_empty_stmt (input_location
));
5274 gfc_add_expr_to_block (&se
->pre
, tmp
);
5279 /* The case with fsym->attr.optional is that of a user subroutine
5280 with an interface indicating an optional argument. When we call
5281 an intrinsic subroutine, however, fsym is NULL, but we might still
5282 have an optional argument, so we proceed to the substitution
5284 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5286 /* If an optional argument is itself an optional dummy argument,
5287 check its presence and substitute a null if absent. This is
5288 only needed when passing an array to an elemental procedure
5289 as then array elements are accessed - or no NULL pointer is
5290 allowed and a "1" or "0" should be passed if not present.
5291 When passing a non-array-descriptor full array to a
5292 non-array-descriptor dummy, no check is needed. For
5293 array-descriptor actual to array-descriptor dummy, see
5294 PR 41911 for why a check has to be inserted.
5295 fsym == NULL is checked as intrinsics required the descriptor
5296 but do not always set fsym. */
5297 if (e
->expr_type
== EXPR_VARIABLE
5298 && e
->symtree
->n
.sym
->attr
.optional
5299 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
5300 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5304 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5305 || fsym
->as
->type
== AS_ASSUMED_RANK
5306 || fsym
->as
->type
== AS_DEFERRED
))))))
5307 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5308 e
->representation
.length
);
5313 /* Obtain the character length of an assumed character length
5314 length procedure from the typespec. */
5315 if (fsym
->ts
.type
== BT_CHARACTER
5316 && parmse
.string_length
== NULL_TREE
5317 && e
->ts
.type
== BT_PROCEDURE
5318 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5319 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5320 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5322 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5323 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5327 if (fsym
&& need_interface_mapping
&& e
)
5328 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5330 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5331 gfc_add_block_to_block (&post
, &parmse
.post
);
5333 /* Allocated allocatable components of derived types must be
5334 deallocated for non-variable scalars. Non-variable arrays are
5335 dealt with in trans-array.c(gfc_conv_array_parameter). */
5336 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5337 && e
->ts
.u
.derived
->attr
.alloc_comp
5338 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
5339 && e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)
5342 tmp
= build_fold_indirect_ref_loc (input_location
,
5344 parm_rank
= e
->rank
;
5352 case (SCALAR_POINTER
):
5353 tmp
= build_fold_indirect_ref_loc (input_location
,
5358 if (e
->expr_type
== EXPR_OP
5359 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5360 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5363 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5364 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5365 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5368 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5370 /* The derived type is passed to gfc_deallocate_alloc_comp.
5371 Therefore, class actuals can handled correctly but derived
5372 types passed to class formals need the _data component. */
5373 tmp
= gfc_class_data_get (tmp
);
5374 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5375 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5378 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5380 gfc_add_expr_to_block (&se
->post
, tmp
);
5383 /* Add argument checking of passing an unallocated/NULL actual to
5384 a nonallocatable/nonpointer dummy. */
5386 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5388 symbol_attribute attr
;
5392 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5393 attr
= gfc_expr_attr (e
);
5395 goto end_pointer_check
;
5397 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5398 allocatable to an optional dummy, cf. 12.5.2.12. */
5399 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5400 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5401 goto end_pointer_check
;
5405 /* If the actual argument is an optional pointer/allocatable and
5406 the formal argument takes an nonpointer optional value,
5407 it is invalid to pass a non-present argument on, even
5408 though there is no technical reason for this in gfortran.
5409 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5410 tree present
, null_ptr
, type
;
5412 if (attr
.allocatable
5413 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5414 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5415 "allocated or not present",
5416 e
->symtree
->n
.sym
->name
);
5417 else if (attr
.pointer
5418 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5419 msg
= xasprintf ("Pointer actual argument '%s' is not "
5420 "associated or not present",
5421 e
->symtree
->n
.sym
->name
);
5422 else if (attr
.proc_pointer
5423 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5424 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5425 "associated or not present",
5426 e
->symtree
->n
.sym
->name
);
5428 goto end_pointer_check
;
5430 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5431 type
= TREE_TYPE (present
);
5432 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5433 boolean_type_node
, present
,
5435 null_pointer_node
));
5436 type
= TREE_TYPE (parmse
.expr
);
5437 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5438 boolean_type_node
, parmse
.expr
,
5440 null_pointer_node
));
5441 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5442 boolean_type_node
, present
, null_ptr
);
5446 if (attr
.allocatable
5447 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5448 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5449 "allocated", e
->symtree
->n
.sym
->name
);
5450 else if (attr
.pointer
5451 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5452 msg
= xasprintf ("Pointer actual argument '%s' is not "
5453 "associated", e
->symtree
->n
.sym
->name
);
5454 else if (attr
.proc_pointer
5455 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5456 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5457 "associated", e
->symtree
->n
.sym
->name
);
5459 goto end_pointer_check
;
5463 /* If the argument is passed by value, we need to strip the
5465 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5466 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5468 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5469 boolean_type_node
, tmp
,
5470 fold_convert (TREE_TYPE (tmp
),
5471 null_pointer_node
));
5474 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5480 /* Deferred length dummies pass the character length by reference
5481 so that the value can be returned. */
5482 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5484 if (INDIRECT_REF_P (parmse
.string_length
))
5485 /* In chains of functions/procedure calls the string_length already
5486 is a pointer to the variable holding the length. Therefore
5487 remove the deref on call. */
5488 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5491 tmp
= parmse
.string_length
;
5492 if (TREE_CODE (tmp
) != VAR_DECL
)
5493 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5494 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5498 /* Character strings are passed as two parameters, a length and a
5499 pointer - except for Bind(c) which only passes the pointer.
5500 An unlimited polymorphic formal argument likewise does not
5502 if (parmse
.string_length
!= NULL_TREE
5503 && !sym
->attr
.is_bind_c
5504 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5505 vec_safe_push (stringargs
, parmse
.string_length
);
5507 /* When calling __copy for character expressions to unlimited
5508 polymorphic entities, the dst argument needs a string length. */
5509 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5510 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5511 && arg
->next
&& arg
->next
->expr
5512 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5513 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5514 vec_safe_push (stringargs
, parmse
.string_length
);
5516 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5517 pass the token and the offset as additional arguments. */
5518 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5519 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5520 && !fsym
->attr
.allocatable
)
5521 || (fsym
->ts
.type
== BT_CLASS
5522 && CLASS_DATA (fsym
)->attr
.codimension
5523 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5525 /* Token and offset. */
5526 vec_safe_push (stringargs
, null_pointer_node
);
5527 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5528 gcc_assert (fsym
->attr
.optional
);
5530 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5531 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5532 && !fsym
->attr
.allocatable
)
5533 || (fsym
->ts
.type
== BT_CLASS
5534 && CLASS_DATA (fsym
)->attr
.codimension
5535 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5537 tree caf_decl
, caf_type
;
5540 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5541 caf_type
= TREE_TYPE (caf_decl
);
5543 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5544 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5545 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5546 tmp
= gfc_conv_descriptor_token (caf_decl
);
5547 else if (DECL_LANG_SPECIFIC (caf_decl
)
5548 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5549 tmp
= GFC_DECL_TOKEN (caf_decl
);
5552 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5553 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5554 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5557 vec_safe_push (stringargs
, tmp
);
5559 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5560 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5561 offset
= build_int_cst (gfc_array_index_type
, 0);
5562 else if (DECL_LANG_SPECIFIC (caf_decl
)
5563 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5564 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5565 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5566 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5568 offset
= build_int_cst (gfc_array_index_type
, 0);
5570 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5571 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5574 gcc_assert (POINTER_TYPE_P (caf_type
));
5578 tmp2
= fsym
->ts
.type
== BT_CLASS
5579 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5580 if ((fsym
->ts
.type
!= BT_CLASS
5581 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5582 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5583 || (fsym
->ts
.type
== BT_CLASS
5584 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5585 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5587 if (fsym
->ts
.type
== BT_CLASS
)
5588 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5591 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5592 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5594 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5595 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5597 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5598 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5601 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5604 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5605 gfc_array_index_type
,
5606 fold_convert (gfc_array_index_type
, tmp2
),
5607 fold_convert (gfc_array_index_type
, tmp
));
5608 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5609 gfc_array_index_type
, offset
, tmp
);
5611 vec_safe_push (stringargs
, offset
);
5614 vec_safe_push (arglist
, parmse
.expr
);
5616 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5623 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5624 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5625 else if (ts
.type
== BT_CHARACTER
)
5627 if (ts
.u
.cl
->length
== NULL
)
5629 /* Assumed character length results are not allowed by 5.1.1.5 of the
5630 standard and are trapped in resolve.c; except in the case of SPREAD
5631 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5632 we take the character length of the first argument for the result.
5633 For dummies, we have to look through the formal argument list for
5634 this function and use the character length found there.*/
5636 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5637 else if (!sym
->attr
.dummy
)
5638 cl
.backend_decl
= (*stringargs
)[0];
5641 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5642 for (; formal
; formal
= formal
->next
)
5643 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5644 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5646 len
= cl
.backend_decl
;
5652 /* Calculate the length of the returned string. */
5653 gfc_init_se (&parmse
, NULL
);
5654 if (need_interface_mapping
)
5655 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5657 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5658 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5659 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5661 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5662 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5663 gfc_charlen_type_node
, tmp
,
5664 build_int_cst (gfc_charlen_type_node
, 0));
5665 cl
.backend_decl
= tmp
;
5668 /* Set up a charlen structure for it. */
5673 len
= cl
.backend_decl
;
5676 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5677 || (!comp
&& gfc_return_by_reference (sym
));
5680 if (se
->direct_byref
)
5682 /* Sometimes, too much indirection can be applied; e.g. for
5683 function_result = array_valued_recursive_function. */
5684 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5685 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5686 && GFC_DESCRIPTOR_TYPE_P
5687 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5688 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5691 /* If the lhs of an assignment x = f(..) is allocatable and
5692 f2003 is allowed, we must do the automatic reallocation.
5693 TODO - deal with intrinsics, without using a temporary. */
5694 if (flag_realloc_lhs
5695 && se
->ss
&& se
->ss
->loop_chain
5696 && se
->ss
->loop_chain
->is_alloc_lhs
5697 && !expr
->value
.function
.isym
5698 && sym
->result
->as
!= NULL
)
5700 /* Evaluate the bounds of the result, if known. */
5701 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5704 /* Perform the automatic reallocation. */
5705 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5707 gfc_add_expr_to_block (&se
->pre
, tmp
);
5709 /* Pass the temporary as the first argument. */
5710 result
= info
->descriptor
;
5713 result
= build_fold_indirect_ref_loc (input_location
,
5715 vec_safe_push (retargs
, se
->expr
);
5717 else if (comp
&& comp
->attr
.dimension
)
5719 gcc_assert (se
->loop
&& info
);
5721 /* Set the type of the array. */
5722 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5723 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5725 /* Evaluate the bounds of the result, if known. */
5726 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5728 /* If the lhs of an assignment x = f(..) is allocatable and
5729 f2003 is allowed, we must not generate the function call
5730 here but should just send back the results of the mapping.
5731 This is signalled by the function ss being flagged. */
5732 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5734 gfc_free_interface_mapping (&mapping
);
5735 return has_alternate_specifier
;
5738 /* Create a temporary to store the result. In case the function
5739 returns a pointer, the temporary will be a shallow copy and
5740 mustn't be deallocated. */
5741 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5742 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5743 tmp
, NULL_TREE
, false,
5744 !comp
->attr
.pointer
, callee_alloc
,
5745 &se
->ss
->info
->expr
->where
);
5747 /* Pass the temporary as the first argument. */
5748 result
= info
->descriptor
;
5749 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5750 vec_safe_push (retargs
, tmp
);
5752 else if (!comp
&& sym
->result
->attr
.dimension
)
5754 gcc_assert (se
->loop
&& info
);
5756 /* Set the type of the array. */
5757 tmp
= gfc_typenode_for_spec (&ts
);
5758 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5760 /* Evaluate the bounds of the result, if known. */
5761 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5763 /* If the lhs of an assignment x = f(..) is allocatable and
5764 f2003 is allowed, we must not generate the function call
5765 here but should just send back the results of the mapping.
5766 This is signalled by the function ss being flagged. */
5767 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5769 gfc_free_interface_mapping (&mapping
);
5770 return has_alternate_specifier
;
5773 /* Create a temporary to store the result. In case the function
5774 returns a pointer, the temporary will be a shallow copy and
5775 mustn't be deallocated. */
5776 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5777 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5778 tmp
, NULL_TREE
, false,
5779 !sym
->attr
.pointer
, callee_alloc
,
5780 &se
->ss
->info
->expr
->where
);
5782 /* Pass the temporary as the first argument. */
5783 result
= info
->descriptor
;
5784 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5785 vec_safe_push (retargs
, tmp
);
5787 else if (ts
.type
== BT_CHARACTER
)
5789 /* Pass the string length. */
5790 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5791 type
= build_pointer_type (type
);
5793 /* Return an address to a char[0:len-1]* temporary for
5794 character pointers. */
5795 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5796 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5798 var
= gfc_create_var (type
, "pstr");
5800 if ((!comp
&& sym
->attr
.allocatable
)
5801 || (comp
&& comp
->attr
.allocatable
))
5803 gfc_add_modify (&se
->pre
, var
,
5804 fold_convert (TREE_TYPE (var
),
5805 null_pointer_node
));
5806 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5807 gfc_add_expr_to_block (&se
->post
, tmp
);
5810 /* Provide an address expression for the function arguments. */
5811 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5814 var
= gfc_conv_string_tmp (se
, type
, len
);
5816 vec_safe_push (retargs
, var
);
5820 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5822 type
= gfc_get_complex_type (ts
.kind
);
5823 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5824 vec_safe_push (retargs
, var
);
5827 /* Add the string length to the argument list. */
5828 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5831 if (TREE_CODE (tmp
) != VAR_DECL
)
5832 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5833 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5834 vec_safe_push (retargs
, tmp
);
5836 else if (ts
.type
== BT_CHARACTER
)
5837 vec_safe_push (retargs
, len
);
5839 gfc_free_interface_mapping (&mapping
);
5841 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5842 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5843 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5844 vec_safe_reserve (retargs
, arglen
);
5846 /* Add the return arguments. */
5847 retargs
->splice (arglist
);
5849 /* Add the hidden present status for optional+value to the arguments. */
5850 retargs
->splice (optionalargs
);
5852 /* Add the hidden string length parameters to the arguments. */
5853 retargs
->splice (stringargs
);
5855 /* We may want to append extra arguments here. This is used e.g. for
5856 calls to libgfortran_matmul_??, which need extra information. */
5857 if (!vec_safe_is_empty (append_args
))
5858 retargs
->splice (append_args
);
5861 /* Generate the actual call. */
5862 if (base_object
== NULL_TREE
)
5863 conv_function_val (se
, sym
, expr
);
5865 conv_base_obj_fcn_val (se
, base_object
, expr
);
5867 /* If there are alternate return labels, function type should be
5868 integer. Can't modify the type in place though, since it can be shared
5869 with other functions. For dummy arguments, the typing is done to
5870 this result, even if it has to be repeated for each call. */
5871 if (has_alternate_specifier
5872 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5874 if (!sym
->attr
.dummy
)
5876 TREE_TYPE (sym
->backend_decl
)
5877 = build_function_type (integer_type_node
,
5878 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5879 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5882 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5885 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5886 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5888 /* Allocatable scalar function results must be freed and nullified
5889 after use. This necessitates the creation of a temporary to
5890 hold the result to prevent duplicate calls. */
5891 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
5892 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
5894 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5895 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
5897 tmp
= gfc_call_free (tmp
);
5898 gfc_add_expr_to_block (&post
, tmp
);
5899 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
5902 /* If we have a pointer function, but we don't want a pointer, e.g.
5905 where f is pointer valued, we have to dereference the result. */
5906 if (!se
->want_pointer
&& !byref
5907 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5908 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5909 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5911 /* f2c calling conventions require a scalar default real function to
5912 return a double precision result. Convert this back to default
5913 real. We only care about the cases that can happen in Fortran 77.
5915 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5916 && sym
->ts
.kind
== gfc_default_real_kind
5917 && !sym
->attr
.always_explicit
)
5918 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5920 /* A pure function may still have side-effects - it may modify its
5922 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5924 if (!sym
->attr
.pure
)
5925 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5930 /* Add the function call to the pre chain. There is no expression. */
5931 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5932 se
->expr
= NULL_TREE
;
5934 if (!se
->direct_byref
)
5936 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5938 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5940 /* Check the data pointer hasn't been modified. This would
5941 happen in a function returning a pointer. */
5942 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5943 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5946 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5949 se
->expr
= info
->descriptor
;
5950 /* Bundle in the string length. */
5951 se
->string_length
= len
;
5953 else if (ts
.type
== BT_CHARACTER
)
5955 /* Dereference for character pointer results. */
5956 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5957 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5958 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5962 se
->string_length
= len
;
5966 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5967 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5972 /* Follow the function call with the argument post block. */
5975 gfc_add_block_to_block (&se
->pre
, &post
);
5977 /* Transformational functions of derived types with allocatable
5978 components must have the result allocatable components copied. */
5979 arg
= expr
->value
.function
.actual
;
5980 if (result
&& arg
&& expr
->rank
5981 && expr
->value
.function
.isym
5982 && expr
->value
.function
.isym
->transformational
5983 && arg
->expr
->ts
.type
== BT_DERIVED
5984 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5987 /* Copy the allocatable components. We have to use a
5988 temporary here to prevent source allocatable components
5989 from being corrupted. */
5990 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5991 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5992 result
, tmp2
, expr
->rank
);
5993 gfc_add_expr_to_block (&se
->pre
, tmp
);
5994 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5996 gfc_add_expr_to_block (&se
->pre
, tmp
);
5998 /* Finally free the temporary's data field. */
5999 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6000 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6001 NULL_TREE
, NULL_TREE
, true,
6003 gfc_add_expr_to_block (&se
->pre
, tmp
);
6008 /* For a function with a class array result, save the result as
6009 a temporary, set the info fields needed by the scalarizer and
6010 call the finalization function of the temporary. Note that the
6011 nullification of allocatable components needed by the result
6012 is done in gfc_trans_assignment_1. */
6013 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6014 && se
->ss
&& se
->ss
->loop
)
6015 || gfc_is_alloc_class_scalar_function (expr
))
6016 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6017 && expr
->must_finalize
)
6022 if (se
->ss
&& se
->ss
->loop
)
6024 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6025 tmp
= gfc_class_data_get (se
->expr
);
6026 info
->descriptor
= tmp
;
6027 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6028 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6029 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6031 tree dim
= gfc_rank_cst
[n
];
6032 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6033 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6038 /* TODO Eliminate the doubling of temporaries. This
6039 one is necessary to ensure no memory leakage. */
6040 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6041 tmp
= gfc_class_data_get (se
->expr
);
6042 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6043 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6046 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6047 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6050 fold_convert (TREE_TYPE (final_fndecl
),
6051 null_pointer_node
));
6052 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6054 tmp
= build_call_expr_loc (input_location
,
6056 gfc_build_addr_expr (NULL
, tmp
),
6057 gfc_class_vtab_size_get (se
->expr
),
6058 boolean_false_node
);
6059 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6060 void_type_node
, is_final
, tmp
,
6061 build_empty_stmt (input_location
));
6063 if (se
->ss
&& se
->ss
->loop
)
6065 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6066 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
6067 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6071 gfc_add_expr_to_block (&se
->post
, tmp
);
6072 tmp
= gfc_class_data_get (se
->expr
);
6073 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
6074 gfc_add_expr_to_block (&se
->post
, tmp
);
6076 expr
->must_finalize
= 0;
6079 gfc_add_block_to_block (&se
->post
, &post
);
6082 return has_alternate_specifier
;
6086 /* Fill a character string with spaces. */
6089 fill_with_spaces (tree start
, tree type
, tree size
)
6091 stmtblock_t block
, loop
;
6092 tree i
, el
, exit_label
, cond
, tmp
;
6094 /* For a simple char type, we can call memset(). */
6095 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6096 return build_call_expr_loc (input_location
,
6097 builtin_decl_explicit (BUILT_IN_MEMSET
),
6099 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6100 lang_hooks
.to_target_charset (' ')),
6103 /* Otherwise, we use a loop:
6104 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6108 /* Initialize variables. */
6109 gfc_init_block (&block
);
6110 i
= gfc_create_var (sizetype
, "i");
6111 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6112 el
= gfc_create_var (build_pointer_type (type
), "el");
6113 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6114 exit_label
= gfc_build_label_decl (NULL_TREE
);
6115 TREE_USED (exit_label
) = 1;
6119 gfc_init_block (&loop
);
6121 /* Exit condition. */
6122 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6123 build_zero_cst (sizetype
));
6124 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6125 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6126 build_empty_stmt (input_location
));
6127 gfc_add_expr_to_block (&loop
, tmp
);
6130 gfc_add_modify (&loop
,
6131 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6132 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6134 /* Increment loop variables. */
6135 gfc_add_modify (&loop
, i
,
6136 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6137 TYPE_SIZE_UNIT (type
)));
6138 gfc_add_modify (&loop
, el
,
6139 fold_build_pointer_plus_loc (input_location
,
6140 el
, TYPE_SIZE_UNIT (type
)));
6142 /* Making the loop... actually loop! */
6143 tmp
= gfc_finish_block (&loop
);
6144 tmp
= build1_v (LOOP_EXPR
, tmp
);
6145 gfc_add_expr_to_block (&block
, tmp
);
6147 /* The exit label. */
6148 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6149 gfc_add_expr_to_block (&block
, tmp
);
6152 return gfc_finish_block (&block
);
6156 /* Generate code to copy a string. */
6159 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6160 int dkind
, tree slength
, tree src
, int skind
)
6162 tree tmp
, dlen
, slen
;
6171 stmtblock_t tempblock
;
6173 gcc_assert (dkind
== skind
);
6175 if (slength
!= NULL_TREE
)
6177 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6178 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6182 slen
= build_int_cst (size_type_node
, 1);
6186 if (dlength
!= NULL_TREE
)
6188 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6189 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6193 dlen
= build_int_cst (size_type_node
, 1);
6197 /* Assign directly if the types are compatible. */
6198 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6199 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6201 gfc_add_modify (block
, dsc
, ssc
);
6205 /* Do nothing if the destination length is zero. */
6206 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6207 build_int_cst (size_type_node
, 0));
6209 /* The following code was previously in _gfortran_copy_string:
6211 // The two strings may overlap so we use memmove.
6213 copy_string (GFC_INTEGER_4 destlen, char * dest,
6214 GFC_INTEGER_4 srclen, const char * src)
6216 if (srclen >= destlen)
6218 // This will truncate if too long.
6219 memmove (dest, src, destlen);
6223 memmove (dest, src, srclen);
6225 memset (&dest[srclen], ' ', destlen - srclen);
6229 We're now doing it here for better optimization, but the logic
6232 /* For non-default character kinds, we have to multiply the string
6233 length by the base type size. */
6234 chartype
= gfc_get_char_type (dkind
);
6235 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6236 fold_convert (size_type_node
, slen
),
6237 fold_convert (size_type_node
,
6238 TYPE_SIZE_UNIT (chartype
)));
6239 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6240 fold_convert (size_type_node
, dlen
),
6241 fold_convert (size_type_node
,
6242 TYPE_SIZE_UNIT (chartype
)));
6244 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6245 dest
= fold_convert (pvoid_type_node
, dest
);
6247 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6249 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6250 src
= fold_convert (pvoid_type_node
, src
);
6252 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6254 /* Truncate string if source is too long. */
6255 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6257 tmp2
= build_call_expr_loc (input_location
,
6258 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6259 3, dest
, src
, dlen
);
6261 /* Else copy and pad with spaces. */
6262 tmp3
= build_call_expr_loc (input_location
,
6263 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6264 3, dest
, src
, slen
);
6266 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6267 tmp4
= fill_with_spaces (tmp4
, chartype
,
6268 fold_build2_loc (input_location
, MINUS_EXPR
,
6269 TREE_TYPE(dlen
), dlen
, slen
));
6271 gfc_init_block (&tempblock
);
6272 gfc_add_expr_to_block (&tempblock
, tmp3
);
6273 gfc_add_expr_to_block (&tempblock
, tmp4
);
6274 tmp3
= gfc_finish_block (&tempblock
);
6276 /* The whole copy_string function is there. */
6277 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6279 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6280 build_empty_stmt (input_location
));
6281 gfc_add_expr_to_block (block
, tmp
);
6285 /* Translate a statement function.
6286 The value of a statement function reference is obtained by evaluating the
6287 expression using the values of the actual arguments for the values of the
6288 corresponding dummy arguments. */
6291 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6295 gfc_formal_arglist
*fargs
;
6296 gfc_actual_arglist
*args
;
6299 gfc_saved_var
*saved_vars
;
6305 sym
= expr
->symtree
->n
.sym
;
6306 args
= expr
->value
.function
.actual
;
6307 gfc_init_se (&lse
, NULL
);
6308 gfc_init_se (&rse
, NULL
);
6311 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6313 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6314 temp_vars
= XCNEWVEC (tree
, n
);
6316 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6317 fargs
= fargs
->next
, n
++)
6319 /* Each dummy shall be specified, explicitly or implicitly, to be
6321 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6324 if (fsym
->ts
.type
== BT_CHARACTER
)
6326 /* Copy string arguments. */
6329 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6330 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6332 /* Create a temporary to hold the value. */
6333 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6334 fsym
->ts
.u
.cl
->backend_decl
6335 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6337 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6338 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6340 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6342 gfc_conv_expr (&rse
, args
->expr
);
6343 gfc_conv_string_parameter (&rse
);
6344 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6345 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6347 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6348 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6349 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6350 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6354 /* For everything else, just evaluate the expression. */
6356 /* Create a temporary to hold the value. */
6357 type
= gfc_typenode_for_spec (&fsym
->ts
);
6358 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6360 gfc_conv_expr (&lse
, args
->expr
);
6362 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6363 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6364 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6370 /* Use the temporary variables in place of the real ones. */
6371 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6372 fargs
= fargs
->next
, n
++)
6373 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6375 gfc_conv_expr (se
, sym
->value
);
6377 if (sym
->ts
.type
== BT_CHARACTER
)
6379 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6381 /* Force the expression to the correct length. */
6382 if (!INTEGER_CST_P (se
->string_length
)
6383 || tree_int_cst_lt (se
->string_length
,
6384 sym
->ts
.u
.cl
->backend_decl
))
6386 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6387 tmp
= gfc_create_var (type
, sym
->name
);
6388 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6389 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6390 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6394 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6397 /* Restore the original variables. */
6398 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6399 fargs
= fargs
->next
, n
++)
6400 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6406 /* Translate a function expression. */
6409 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6413 if (expr
->value
.function
.isym
)
6415 gfc_conv_intrinsic_function (se
, expr
);
6419 /* expr.value.function.esym is the resolved (specific) function symbol for
6420 most functions. However this isn't set for dummy procedures. */
6421 sym
= expr
->value
.function
.esym
;
6423 sym
= expr
->symtree
->n
.sym
;
6425 /* The IEEE_ARITHMETIC functions are caught here. */
6426 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6427 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6430 /* We distinguish statement functions from general functions to improve
6431 runtime performance. */
6432 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6434 gfc_conv_statement_function (se
, expr
);
6438 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6443 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6446 is_zero_initializer_p (gfc_expr
* expr
)
6448 if (expr
->expr_type
!= EXPR_CONSTANT
)
6451 /* We ignore constants with prescribed memory representations for now. */
6452 if (expr
->representation
.string
)
6455 switch (expr
->ts
.type
)
6458 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6461 return mpfr_zero_p (expr
->value
.real
)
6462 && MPFR_SIGN (expr
->value
.real
) >= 0;
6465 return expr
->value
.logical
== 0;
6468 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6469 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6470 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6471 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6481 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6486 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6487 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6489 gfc_conv_tmp_array_ref (se
);
6493 /* Build a static initializer. EXPR is the expression for the initial value.
6494 The other parameters describe the variable of the component being
6495 initialized. EXPR may be null. */
6498 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6499 bool array
, bool pointer
, bool procptr
)
6503 if (!(expr
|| pointer
|| procptr
))
6506 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6507 (these are the only two iso_c_binding derived types that can be
6508 used as initialization expressions). If so, we need to modify
6509 the 'expr' to be that for a (void *). */
6510 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6511 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6513 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6515 /* The derived symbol has already been converted to a (void *). Use
6517 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6518 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6520 gfc_init_se (&se
, NULL
);
6521 gfc_conv_constant (&se
, expr
);
6522 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6526 if (array
&& !procptr
)
6529 /* Arrays need special handling. */
6531 ctor
= gfc_build_null_descriptor (type
);
6532 /* Special case assigning an array to zero. */
6533 else if (is_zero_initializer_p (expr
))
6534 ctor
= build_constructor (type
, NULL
);
6536 ctor
= gfc_conv_array_initializer (type
, expr
);
6537 TREE_STATIC (ctor
) = 1;
6540 else if (pointer
|| procptr
)
6542 if (ts
->type
== BT_CLASS
&& !procptr
)
6544 gfc_init_se (&se
, NULL
);
6545 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6546 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6547 TREE_STATIC (se
.expr
) = 1;
6550 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6551 return fold_convert (type
, null_pointer_node
);
6554 gfc_init_se (&se
, NULL
);
6555 se
.want_pointer
= 1;
6556 gfc_conv_expr (&se
, expr
);
6557 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6567 gfc_init_se (&se
, NULL
);
6568 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6569 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6571 gfc_conv_structure (&se
, expr
, 1);
6572 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6573 TREE_STATIC (se
.expr
) = 1;
6578 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6579 TREE_STATIC (ctor
) = 1;
6584 gfc_init_se (&se
, NULL
);
6585 gfc_conv_constant (&se
, expr
);
6586 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6593 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6599 gfc_array_info
*lss_array
;
6606 gfc_start_block (&block
);
6608 /* Initialize the scalarizer. */
6609 gfc_init_loopinfo (&loop
);
6611 gfc_init_se (&lse
, NULL
);
6612 gfc_init_se (&rse
, NULL
);
6615 rss
= gfc_walk_expr (expr
);
6616 if (rss
== gfc_ss_terminator
)
6617 /* The rhs is scalar. Add a ss for the expression. */
6618 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6620 /* Create a SS for the destination. */
6621 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6623 lss_array
= &lss
->info
->data
.array
;
6624 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6625 lss_array
->descriptor
= dest
;
6626 lss_array
->data
= gfc_conv_array_data (dest
);
6627 lss_array
->offset
= gfc_conv_array_offset (dest
);
6628 for (n
= 0; n
< cm
->as
->rank
; n
++)
6630 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6631 lss_array
->stride
[n
] = gfc_index_one_node
;
6633 mpz_init (lss_array
->shape
[n
]);
6634 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6635 cm
->as
->lower
[n
]->value
.integer
);
6636 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6639 /* Associate the SS with the loop. */
6640 gfc_add_ss_to_loop (&loop
, lss
);
6641 gfc_add_ss_to_loop (&loop
, rss
);
6643 /* Calculate the bounds of the scalarization. */
6644 gfc_conv_ss_startstride (&loop
);
6646 /* Setup the scalarizing loops. */
6647 gfc_conv_loop_setup (&loop
, &expr
->where
);
6649 /* Setup the gfc_se structures. */
6650 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6651 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6654 gfc_mark_ss_chain_used (rss
, 1);
6656 gfc_mark_ss_chain_used (lss
, 1);
6658 /* Start the scalarized loop body. */
6659 gfc_start_scalarized_body (&loop
, &body
);
6661 gfc_conv_tmp_array_ref (&lse
);
6662 if (cm
->ts
.type
== BT_CHARACTER
)
6663 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6665 gfc_conv_expr (&rse
, expr
);
6667 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6668 gfc_add_expr_to_block (&body
, tmp
);
6670 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6672 /* Generate the copying loops. */
6673 gfc_trans_scalarizing_loops (&loop
, &body
);
6675 /* Wrap the whole thing up. */
6676 gfc_add_block_to_block (&block
, &loop
.pre
);
6677 gfc_add_block_to_block (&block
, &loop
.post
);
6679 gcc_assert (lss_array
->shape
!= NULL
);
6680 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6681 gfc_cleanup_loop (&loop
);
6683 return gfc_finish_block (&block
);
6688 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6698 gfc_expr
*arg
= NULL
;
6700 gfc_start_block (&block
);
6701 gfc_init_se (&se
, NULL
);
6703 /* Get the descriptor for the expressions. */
6704 se
.want_pointer
= 0;
6705 gfc_conv_expr_descriptor (&se
, expr
);
6706 gfc_add_block_to_block (&block
, &se
.pre
);
6707 gfc_add_modify (&block
, dest
, se
.expr
);
6709 /* Deal with arrays of derived types with allocatable components. */
6710 if (cm
->ts
.type
== BT_DERIVED
6711 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6712 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6715 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6716 && CLASS_DATA(cm
)->attr
.allocatable
)
6718 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6719 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6724 tmp
= TREE_TYPE (dest
);
6725 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6726 tmp
, expr
->rank
, NULL_TREE
);
6730 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6731 TREE_TYPE(cm
->backend_decl
),
6732 cm
->as
->rank
, NULL_TREE
);
6734 gfc_add_expr_to_block (&block
, tmp
);
6735 gfc_add_block_to_block (&block
, &se
.post
);
6737 if (expr
->expr_type
!= EXPR_VARIABLE
)
6738 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6741 /* We need to know if the argument of a conversion function is a
6742 variable, so that the correct lower bound can be used. */
6743 if (expr
->expr_type
== EXPR_FUNCTION
6744 && expr
->value
.function
.isym
6745 && expr
->value
.function
.isym
->conversion
6746 && expr
->value
.function
.actual
->expr
6747 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6748 arg
= expr
->value
.function
.actual
->expr
;
6750 /* Obtain the array spec of full array references. */
6752 as
= gfc_get_full_arrayspec_from_expr (arg
);
6754 as
= gfc_get_full_arrayspec_from_expr (expr
);
6756 /* Shift the lbound and ubound of temporaries to being unity,
6757 rather than zero, based. Always calculate the offset. */
6758 offset
= gfc_conv_descriptor_offset_get (dest
);
6759 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6760 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6762 for (n
= 0; n
< expr
->rank
; n
++)
6767 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6768 TODO It looks as if gfc_conv_expr_descriptor should return
6769 the correct bounds and that the following should not be
6770 necessary. This would simplify gfc_conv_intrinsic_bound
6772 if (as
&& as
->lower
[n
])
6775 gfc_init_se (&lbse
, NULL
);
6776 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6777 gfc_add_block_to_block (&block
, &lbse
.pre
);
6778 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6782 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6783 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6787 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6790 lbound
= gfc_index_one_node
;
6792 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6794 /* Shift the bounds and set the offset accordingly. */
6795 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6796 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6797 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6798 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6800 gfc_conv_descriptor_ubound_set (&block
, dest
,
6801 gfc_rank_cst
[n
], tmp
);
6802 gfc_conv_descriptor_lbound_set (&block
, dest
,
6803 gfc_rank_cst
[n
], lbound
);
6805 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6806 gfc_conv_descriptor_lbound_get (dest
,
6808 gfc_conv_descriptor_stride_get (dest
,
6810 gfc_add_modify (&block
, tmp2
, tmp
);
6811 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6813 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6818 /* If a conversion expression has a null data pointer
6819 argument, nullify the allocatable component. */
6823 if (arg
->symtree
->n
.sym
->attr
.allocatable
6824 || arg
->symtree
->n
.sym
->attr
.pointer
)
6826 non_null_expr
= gfc_finish_block (&block
);
6827 gfc_start_block (&block
);
6828 gfc_conv_descriptor_data_set (&block
, dest
,
6830 null_expr
= gfc_finish_block (&block
);
6831 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6832 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6833 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6834 return build3_v (COND_EXPR
, tmp
,
6835 null_expr
, non_null_expr
);
6839 return gfc_finish_block (&block
);
6843 /* Allocate or reallocate scalar component, as necessary. */
6846 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6856 tree lhs_cl_size
= NULL_TREE
;
6861 if (!expr2
|| expr2
->rank
)
6864 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6866 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6868 char name
[GFC_MAX_SYMBOL_LEN
+9];
6869 gfc_component
*strlen
;
6870 /* Use the rhs string length and the lhs element size. */
6871 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6872 if (!expr2
->ts
.u
.cl
->backend_decl
)
6874 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6875 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6878 size
= expr2
->ts
.u
.cl
->backend_decl
;
6880 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6882 sprintf (name
, "_%s_length", cm
->name
);
6883 strlen
= gfc_find_component (sym
, name
, true, true);
6884 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6885 gfc_charlen_type_node
,
6886 TREE_OPERAND (comp
, 0),
6887 strlen
->backend_decl
, NULL_TREE
);
6889 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6890 tmp
= TYPE_SIZE_UNIT (tmp
);
6891 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6892 TREE_TYPE (tmp
), tmp
,
6893 fold_convert (TREE_TYPE (tmp
), size
));
6897 /* Otherwise use the length in bytes of the rhs. */
6898 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6899 size_in_bytes
= size
;
6902 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6903 size_in_bytes
, size_one_node
);
6905 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6907 tmp
= build_call_expr_loc (input_location
,
6908 builtin_decl_explicit (BUILT_IN_CALLOC
),
6909 2, build_one_cst (size_type_node
),
6911 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6912 gfc_add_modify (block
, comp
, tmp
);
6916 tmp
= build_call_expr_loc (input_location
,
6917 builtin_decl_explicit (BUILT_IN_MALLOC
),
6919 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6920 ptr
= gfc_class_data_get (comp
);
6923 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6924 gfc_add_modify (block
, ptr
, tmp
);
6927 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6928 /* Update the lhs character length. */
6929 gfc_add_modify (block
, lhs_cl_size
, size
);
6933 /* Assign a single component of a derived type constructor. */
6936 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6937 gfc_symbol
*sym
, bool init
)
6945 gfc_start_block (&block
);
6947 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6949 /* Only care about pointers here, not about allocatables. */
6950 gfc_init_se (&se
, NULL
);
6951 /* Pointer component. */
6952 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6953 && !cm
->attr
.proc_pointer
)
6955 /* Array pointer. */
6956 if (expr
->expr_type
== EXPR_NULL
)
6957 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6960 se
.direct_byref
= 1;
6962 gfc_conv_expr_descriptor (&se
, expr
);
6963 gfc_add_block_to_block (&block
, &se
.pre
);
6964 gfc_add_block_to_block (&block
, &se
.post
);
6969 /* Scalar pointers. */
6970 se
.want_pointer
= 1;
6971 gfc_conv_expr (&se
, expr
);
6972 gfc_add_block_to_block (&block
, &se
.pre
);
6974 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6975 && expr
->symtree
->n
.sym
->attr
.dummy
)
6976 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6978 gfc_add_modify (&block
, dest
,
6979 fold_convert (TREE_TYPE (dest
), se
.expr
));
6980 gfc_add_block_to_block (&block
, &se
.post
);
6983 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6985 /* NULL initialization for CLASS components. */
6986 tmp
= gfc_trans_structure_assign (dest
,
6987 gfc_class_initializer (&cm
->ts
, expr
),
6989 gfc_add_expr_to_block (&block
, tmp
);
6991 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6992 && !cm
->attr
.proc_pointer
)
6994 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6995 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6996 else if (cm
->attr
.allocatable
)
6998 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6999 gfc_add_expr_to_block (&block
, tmp
);
7003 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7004 gfc_add_expr_to_block (&block
, tmp
);
7007 else if (cm
->ts
.type
== BT_CLASS
7008 && CLASS_DATA (cm
)->attr
.dimension
7009 && CLASS_DATA (cm
)->attr
.allocatable
7010 && expr
->ts
.type
== BT_DERIVED
)
7012 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7013 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7014 tmp
= gfc_class_vptr_get (dest
);
7015 gfc_add_modify (&block
, tmp
,
7016 fold_convert (TREE_TYPE (tmp
), vtab
));
7017 tmp
= gfc_class_data_get (dest
);
7018 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7019 gfc_add_expr_to_block (&block
, tmp
);
7021 else if (init
&& (cm
->attr
.allocatable
7022 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
7024 /* Take care about non-array allocatable components here. The alloc_*
7025 routine below is motivated by the alloc_scalar_allocatable_for_
7026 assignment() routine, but with the realloc portions removed and
7028 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7033 /* The remainder of these instructions follow the if (cm->attr.pointer)
7034 if (!cm->attr.dimension) part above. */
7035 gfc_init_se (&se
, NULL
);
7036 gfc_conv_expr (&se
, expr
);
7037 gfc_add_block_to_block (&block
, &se
.pre
);
7039 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7040 && expr
->symtree
->n
.sym
->attr
.dummy
)
7041 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7043 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7045 tmp
= gfc_class_data_get (dest
);
7046 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7047 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7048 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7049 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7050 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7053 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7055 /* For deferred strings insert a memcpy. */
7056 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7059 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7060 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7062 : expr
->ts
.u
.cl
->backend_decl
);
7063 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7064 gfc_add_expr_to_block (&block
, tmp
);
7067 gfc_add_modify (&block
, tmp
,
7068 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7069 gfc_add_block_to_block (&block
, &se
.post
);
7071 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7073 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7075 tree dealloc
= NULL_TREE
;
7076 gfc_init_se (&se
, NULL
);
7077 gfc_conv_expr (&se
, expr
);
7078 gfc_add_block_to_block (&block
, &se
.pre
);
7079 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7080 expression in a temporary variable and deallocate the allocatable
7081 components. Then we can the copy the expression to the result. */
7082 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7083 && expr
->expr_type
!= EXPR_VARIABLE
)
7085 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7086 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7089 gfc_add_modify (&block
, dest
,
7090 fold_convert (TREE_TYPE (dest
), se
.expr
));
7091 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7092 && expr
->expr_type
!= EXPR_NULL
)
7094 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7096 gfc_add_expr_to_block (&block
, tmp
);
7097 if (dealloc
!= NULL_TREE
)
7098 gfc_add_expr_to_block (&block
, dealloc
);
7100 gfc_add_block_to_block (&block
, &se
.post
);
7104 /* Nested constructors. */
7105 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7106 gfc_add_expr_to_block (&block
, tmp
);
7109 else if (gfc_deferred_strlen (cm
, &tmp
))
7113 gcc_assert (strlen
);
7114 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7116 TREE_OPERAND (dest
, 0),
7119 if (expr
->expr_type
== EXPR_NULL
)
7121 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7122 gfc_add_modify (&block
, dest
, tmp
);
7123 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7124 gfc_add_modify (&block
, strlen
, tmp
);
7129 gfc_init_se (&se
, NULL
);
7130 gfc_conv_expr (&se
, expr
);
7131 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7132 tmp
= build_call_expr_loc (input_location
,
7133 builtin_decl_explicit (BUILT_IN_MALLOC
),
7135 gfc_add_modify (&block
, dest
,
7136 fold_convert (TREE_TYPE (dest
), tmp
));
7137 gfc_add_modify (&block
, strlen
, se
.string_length
);
7138 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7139 gfc_add_expr_to_block (&block
, tmp
);
7142 else if (!cm
->attr
.artificial
)
7144 /* Scalar component (excluding deferred parameters). */
7145 gfc_init_se (&se
, NULL
);
7146 gfc_init_se (&lse
, NULL
);
7148 gfc_conv_expr (&se
, expr
);
7149 if (cm
->ts
.type
== BT_CHARACTER
)
7150 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7152 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
7153 gfc_add_expr_to_block (&block
, tmp
);
7155 return gfc_finish_block (&block
);
7158 /* Assign a derived type constructor to a variable. */
7161 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7169 gfc_start_block (&block
);
7170 cm
= expr
->ts
.u
.derived
->components
;
7172 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7173 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7174 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7178 gcc_assert (cm
->backend_decl
== NULL
);
7179 gfc_init_se (&se
, NULL
);
7180 gfc_init_se (&lse
, NULL
);
7181 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7183 gfc_add_modify (&block
, lse
.expr
,
7184 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7186 return gfc_finish_block (&block
);
7189 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7190 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7192 /* Skip absent members in default initializers. */
7193 if (!c
->expr
&& !cm
->attr
.allocatable
)
7196 field
= cm
->backend_decl
;
7197 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7198 dest
, field
, NULL_TREE
);
7201 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7202 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7207 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7208 expr
->ts
.u
.derived
, init
);
7209 gfc_add_expr_to_block (&block
, tmp
);
7211 return gfc_finish_block (&block
);
7214 /* Build an expression for a constructor. If init is nonzero then
7215 this is part of a static variable initializer. */
7218 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7225 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7227 gcc_assert (se
->ss
== NULL
);
7228 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7229 type
= gfc_typenode_for_spec (&expr
->ts
);
7233 /* Create a temporary variable and fill it in. */
7234 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7235 /* The symtree in expr is NULL, if the code to generate is for
7236 initializing the static members only. */
7237 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7238 gfc_add_expr_to_block (&se
->pre
, tmp
);
7242 cm
= expr
->ts
.u
.derived
->components
;
7244 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7245 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7247 /* Skip absent members in default initializers and allocatable
7248 components. Although the latter have a default initializer
7249 of EXPR_NULL,... by default, the static nullify is not needed
7250 since this is done every time we come into scope. */
7251 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7254 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7255 && strcmp (cm
->name
, "_extends") == 0
7256 && cm
->initializer
->symtree
)
7260 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7261 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7262 vtab
= unshare_expr_without_location (vtab
);
7263 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7265 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7267 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7268 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7269 fold_convert (TREE_TYPE (cm
->backend_decl
),
7272 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7273 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7274 fold_convert (TREE_TYPE (cm
->backend_decl
),
7275 integer_zero_node
));
7278 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7279 TREE_TYPE (cm
->backend_decl
),
7280 cm
->attr
.dimension
, cm
->attr
.pointer
,
7281 cm
->attr
.proc_pointer
);
7282 val
= unshare_expr_without_location (val
);
7284 /* Append it to the constructor list. */
7285 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7288 se
->expr
= build_constructor (type
, v
);
7290 TREE_CONSTANT (se
->expr
) = 1;
7294 /* Translate a substring expression. */
7297 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7303 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7305 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7306 expr
->value
.character
.length
,
7307 expr
->value
.character
.string
);
7309 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7310 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7313 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7317 /* Entry point for expression translation. Evaluates a scalar quantity.
7318 EXPR is the expression to be translated, and SE is the state structure if
7319 called from within the scalarized. */
7322 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7327 if (ss
&& ss
->info
->expr
== expr
7328 && (ss
->info
->type
== GFC_SS_SCALAR
7329 || ss
->info
->type
== GFC_SS_REFERENCE
))
7331 gfc_ss_info
*ss_info
;
7334 /* Substitute a scalar expression evaluated outside the scalarization
7336 se
->expr
= ss_info
->data
.scalar
.value
;
7337 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7338 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7340 se
->string_length
= ss_info
->string_length
;
7341 gfc_advance_se_ss_chain (se
);
7345 /* We need to convert the expressions for the iso_c_binding derived types.
7346 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7347 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7348 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7349 updated to be an integer with a kind equal to the size of a (void *). */
7350 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7351 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7353 if (expr
->expr_type
== EXPR_VARIABLE
7354 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7355 || expr
->symtree
->n
.sym
->intmod_sym_id
7356 == ISOCBINDING_NULL_FUNPTR
))
7358 /* Set expr_type to EXPR_NULL, which will result in
7359 null_pointer_node being used below. */
7360 expr
->expr_type
= EXPR_NULL
;
7364 /* Update the type/kind of the expression to be what the new
7365 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7366 expr
->ts
.type
= BT_INTEGER
;
7367 expr
->ts
.f90_type
= BT_VOID
;
7368 expr
->ts
.kind
= gfc_index_integer_kind
;
7372 gfc_fix_class_refs (expr
);
7374 switch (expr
->expr_type
)
7377 gfc_conv_expr_op (se
, expr
);
7381 gfc_conv_function_expr (se
, expr
);
7385 gfc_conv_constant (se
, expr
);
7389 gfc_conv_variable (se
, expr
);
7393 se
->expr
= null_pointer_node
;
7396 case EXPR_SUBSTRING
:
7397 gfc_conv_substring_expr (se
, expr
);
7400 case EXPR_STRUCTURE
:
7401 gfc_conv_structure (se
, expr
, 0);
7405 gfc_conv_array_constructor_expr (se
, expr
);
7414 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7415 of an assignment. */
7417 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7419 gfc_conv_expr (se
, expr
);
7420 /* All numeric lvalues should have empty post chains. If not we need to
7421 figure out a way of rewriting an lvalue so that it has no post chain. */
7422 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7425 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7426 numeric expressions. Used for scalar values where inserting cleanup code
7429 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7433 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7434 gfc_conv_expr (se
, expr
);
7437 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7438 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7440 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7444 /* Helper to translate an expression and convert it to a particular type. */
7446 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7448 gfc_conv_expr_val (se
, expr
);
7449 se
->expr
= convert (type
, se
->expr
);
7453 /* Converts an expression so that it can be passed by reference. Scalar
7457 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7463 if (ss
&& ss
->info
->expr
== expr
7464 && ss
->info
->type
== GFC_SS_REFERENCE
)
7466 /* Returns a reference to the scalar evaluated outside the loop
7468 gfc_conv_expr (se
, expr
);
7470 if (expr
->ts
.type
== BT_CHARACTER
7471 && expr
->expr_type
!= EXPR_FUNCTION
)
7472 gfc_conv_string_parameter (se
);
7474 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7479 if (expr
->ts
.type
== BT_CHARACTER
)
7481 gfc_conv_expr (se
, expr
);
7482 gfc_conv_string_parameter (se
);
7486 if (expr
->expr_type
== EXPR_VARIABLE
)
7488 se
->want_pointer
= 1;
7489 gfc_conv_expr (se
, expr
);
7492 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7493 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7494 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7500 if (expr
->expr_type
== EXPR_FUNCTION
7501 && ((expr
->value
.function
.esym
7502 && expr
->value
.function
.esym
->result
->attr
.pointer
7503 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7504 || (!expr
->value
.function
.esym
&& !expr
->ref
7505 && expr
->symtree
->n
.sym
->attr
.pointer
7506 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7508 se
->want_pointer
= 1;
7509 gfc_conv_expr (se
, expr
);
7510 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7511 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7516 gfc_conv_expr (se
, expr
);
7518 /* Create a temporary var to hold the value. */
7519 if (TREE_CONSTANT (se
->expr
))
7521 tree tmp
= se
->expr
;
7522 STRIP_TYPE_NOPS (tmp
);
7523 var
= build_decl (input_location
,
7524 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7525 DECL_INITIAL (var
) = tmp
;
7526 TREE_STATIC (var
) = 1;
7531 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7532 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7534 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7536 /* Take the address of that value. */
7537 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7538 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7539 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7540 && expr
->ts
.u
.derived
->attr
.alloc_comp
7541 && expr
->expr_type
!= EXPR_VARIABLE
)
7545 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7546 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7548 /* The components shall be deallocated before
7549 their containing entity. */
7550 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7556 gfc_trans_pointer_assign (gfc_code
* code
)
7558 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7562 /* Generate code for a pointer assignment. */
7565 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7567 gfc_expr
*expr1_vptr
= NULL
;
7577 gfc_start_block (&block
);
7579 gfc_init_se (&lse
, NULL
);
7581 /* Check whether the expression is a scalar or not; we cannot use
7582 expr1->rank as it can be nonzero for proc pointers. */
7583 ss
= gfc_walk_expr (expr1
);
7584 scalar
= ss
== gfc_ss_terminator
;
7586 gfc_free_ss_chain (ss
);
7588 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7589 && expr2
->expr_type
!= EXPR_FUNCTION
)
7591 gfc_add_data_component (expr2
);
7592 /* The following is required as gfc_add_data_component doesn't
7593 update ts.type if there is a tailing REF_ARRAY. */
7594 expr2
->ts
.type
= BT_DERIVED
;
7599 /* Scalar pointers. */
7600 lse
.want_pointer
= 1;
7601 gfc_conv_expr (&lse
, expr1
);
7602 gfc_init_se (&rse
, NULL
);
7603 rse
.want_pointer
= 1;
7604 gfc_conv_expr (&rse
, expr2
);
7606 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7607 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7608 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7611 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7612 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7613 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7616 gfc_add_block_to_block (&block
, &lse
.pre
);
7617 gfc_add_block_to_block (&block
, &rse
.pre
);
7619 /* For string assignments to unlimited polymorphic pointers add an
7620 assignment of the string_length to the _len component of the
7622 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7623 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7624 && (expr2
->ts
.type
== BT_CHARACTER
||
7625 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7626 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7630 len_comp
= gfc_get_len_component (expr1
);
7631 gfc_init_se (&se
, NULL
);
7632 gfc_conv_expr (&se
, len_comp
);
7634 /* ptr % _len = len (str) */
7635 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7636 lse
.string_length
= se
.expr
;
7637 gfc_free_expr (len_comp
);
7640 /* Check character lengths if character expression. The test is only
7641 really added if -fbounds-check is enabled. Exclude deferred
7642 character length lefthand sides. */
7643 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7644 && !expr1
->ts
.deferred
7645 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7646 && !gfc_is_proc_ptr_comp (expr1
))
7648 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7649 gcc_assert (lse
.string_length
&& rse
.string_length
);
7650 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7651 lse
.string_length
, rse
.string_length
,
7655 /* The assignment to an deferred character length sets the string
7656 length to that of the rhs. */
7657 if (expr1
->ts
.deferred
)
7659 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7660 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7661 else if (lse
.string_length
!= NULL
)
7662 gfc_add_modify (&block
, lse
.string_length
,
7663 build_int_cst (gfc_charlen_type_node
, 0));
7666 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7667 rse
.expr
= gfc_class_data_get (rse
.expr
);
7669 gfc_add_modify (&block
, lse
.expr
,
7670 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7672 gfc_add_block_to_block (&block
, &rse
.post
);
7673 gfc_add_block_to_block (&block
, &lse
.post
);
7680 tree strlen_rhs
= NULL_TREE
;
7682 /* Array pointer. Find the last reference on the LHS and if it is an
7683 array section ref, we're dealing with bounds remapping. In this case,
7684 set it to AR_FULL so that gfc_conv_expr_descriptor does
7685 not see it and process the bounds remapping afterwards explicitly. */
7686 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7687 if (!remap
->next
&& remap
->type
== REF_ARRAY
7688 && remap
->u
.ar
.type
== AR_SECTION
)
7690 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7692 gfc_init_se (&lse
, NULL
);
7694 lse
.descriptor_only
= 1;
7695 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7696 && expr1
->ts
.type
== BT_CLASS
)
7697 expr1_vptr
= gfc_copy_expr (expr1
);
7698 gfc_conv_expr_descriptor (&lse
, expr1
);
7699 strlen_lhs
= lse
.string_length
;
7702 if (expr2
->expr_type
== EXPR_NULL
)
7704 /* Just set the data pointer to null. */
7705 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7707 else if (rank_remap
)
7709 /* If we are rank-remapping, just get the RHS's descriptor and
7710 process this later on. */
7711 gfc_init_se (&rse
, NULL
);
7712 rse
.direct_byref
= 1;
7713 rse
.byref_noassign
= 1;
7715 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7717 gfc_conv_function_expr (&rse
, expr2
);
7719 if (expr1
->ts
.type
!= BT_CLASS
)
7720 rse
.expr
= gfc_class_data_get (rse
.expr
);
7723 gfc_add_block_to_block (&block
, &rse
.pre
);
7724 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7725 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7727 gfc_add_vptr_component (expr1_vptr
);
7728 gfc_init_se (&rse
, NULL
);
7729 rse
.want_pointer
= 1;
7730 gfc_conv_expr (&rse
, expr1_vptr
);
7731 gfc_add_modify (&lse
.pre
, rse
.expr
,
7732 fold_convert (TREE_TYPE (rse
.expr
),
7733 gfc_class_vptr_get (tmp
)));
7734 rse
.expr
= gfc_class_data_get (tmp
);
7737 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7739 tree bound
[GFC_MAX_DIMENSIONS
];
7742 for (i
= 0; i
< expr2
->rank
; i
++)
7743 bound
[i
] = NULL_TREE
;
7744 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7745 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7747 GFC_ARRAY_POINTER_CONT
, false);
7748 tmp
= gfc_create_var (tmp
, "ptrtemp");
7749 lse
.descriptor_only
= 0;
7751 lse
.direct_byref
= 1;
7752 gfc_conv_expr_descriptor (&lse
, expr2
);
7753 strlen_rhs
= lse
.string_length
;
7758 gfc_conv_expr_descriptor (&rse
, expr2
);
7759 strlen_rhs
= rse
.string_length
;
7762 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7764 /* Assign directly to the LHS's descriptor. */
7765 lse
.descriptor_only
= 0;
7766 lse
.direct_byref
= 1;
7767 gfc_conv_expr_descriptor (&lse
, expr2
);
7768 strlen_rhs
= lse
.string_length
;
7770 /* If this is a subreference array pointer assignment, use the rhs
7771 descriptor element size for the lhs span. */
7772 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7774 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7775 gfc_init_se (&rse
, NULL
);
7776 rse
.descriptor_only
= 1;
7777 gfc_conv_expr (&rse
, expr2
);
7778 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7779 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7780 if (!INTEGER_CST_P (tmp
))
7781 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7782 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7785 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7787 gfc_init_se (&rse
, NULL
);
7788 rse
.want_pointer
= 1;
7789 gfc_conv_function_expr (&rse
, expr2
);
7790 if (expr1
->ts
.type
!= BT_CLASS
)
7792 rse
.expr
= gfc_class_data_get (rse
.expr
);
7793 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7797 gfc_add_block_to_block (&block
, &rse
.pre
);
7798 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7799 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7801 gfc_add_vptr_component (expr1_vptr
);
7802 gfc_init_se (&rse
, NULL
);
7803 rse
.want_pointer
= 1;
7804 gfc_conv_expr (&rse
, expr1_vptr
);
7805 gfc_add_modify (&lse
.pre
, rse
.expr
,
7806 fold_convert (TREE_TYPE (rse
.expr
),
7807 gfc_class_vptr_get (tmp
)));
7808 rse
.expr
= gfc_class_data_get (tmp
);
7809 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7814 /* Assign to a temporary descriptor and then copy that
7815 temporary to the pointer. */
7816 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7817 lse
.descriptor_only
= 0;
7819 lse
.direct_byref
= 1;
7820 gfc_conv_expr_descriptor (&lse
, expr2
);
7821 strlen_rhs
= lse
.string_length
;
7822 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7826 gfc_free_expr (expr1_vptr
);
7828 gfc_add_block_to_block (&block
, &lse
.pre
);
7830 gfc_add_block_to_block (&block
, &rse
.pre
);
7832 /* If we do bounds remapping, update LHS descriptor accordingly. */
7836 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7840 /* Do rank remapping. We already have the RHS's descriptor
7841 converted in rse and now have to build the correct LHS
7842 descriptor for it. */
7846 tree lbound
, ubound
;
7849 dtype
= gfc_conv_descriptor_dtype (desc
);
7850 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7851 gfc_add_modify (&block
, dtype
, tmp
);
7853 /* Copy data pointer. */
7854 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7855 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7857 /* Copy offset but adjust it such that it would correspond
7858 to a lbound of zero. */
7859 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7860 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7862 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7864 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7866 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7867 gfc_array_index_type
, stride
, lbound
);
7868 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7869 gfc_array_index_type
, offs
, tmp
);
7871 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7873 /* Set the bounds as declared for the LHS and calculate strides as
7874 well as another offset update accordingly. */
7875 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7877 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7882 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7884 /* Convert declared bounds. */
7885 gfc_init_se (&lower_se
, NULL
);
7886 gfc_init_se (&upper_se
, NULL
);
7887 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7888 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7890 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7891 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7893 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7894 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7896 lbound
= gfc_evaluate_now (lbound
, &block
);
7897 ubound
= gfc_evaluate_now (ubound
, &block
);
7899 gfc_add_block_to_block (&block
, &lower_se
.post
);
7900 gfc_add_block_to_block (&block
, &upper_se
.post
);
7902 /* Set bounds in descriptor. */
7903 gfc_conv_descriptor_lbound_set (&block
, desc
,
7904 gfc_rank_cst
[dim
], lbound
);
7905 gfc_conv_descriptor_ubound_set (&block
, desc
,
7906 gfc_rank_cst
[dim
], ubound
);
7909 stride
= gfc_evaluate_now (stride
, &block
);
7910 gfc_conv_descriptor_stride_set (&block
, desc
,
7911 gfc_rank_cst
[dim
], stride
);
7913 /* Update offset. */
7914 offs
= gfc_conv_descriptor_offset_get (desc
);
7915 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7916 gfc_array_index_type
, lbound
, stride
);
7917 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7918 gfc_array_index_type
, offs
, tmp
);
7919 offs
= gfc_evaluate_now (offs
, &block
);
7920 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7922 /* Update stride. */
7923 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7924 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7925 gfc_array_index_type
, stride
, tmp
);
7930 /* Bounds remapping. Just shift the lower bounds. */
7932 gcc_assert (expr1
->rank
== expr2
->rank
);
7934 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7938 gcc_assert (remap
->u
.ar
.start
[dim
]);
7939 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7940 gfc_init_se (&lbound_se
, NULL
);
7941 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7943 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7944 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7945 dim
, lbound_se
.expr
);
7946 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7951 /* Check string lengths if applicable. The check is only really added
7952 to the output code if -fbounds-check is enabled. */
7953 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7955 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7956 gcc_assert (strlen_lhs
&& strlen_rhs
);
7957 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7958 strlen_lhs
, strlen_rhs
, &block
);
7961 /* If rank remapping was done, check with -fcheck=bounds that
7962 the target is at least as large as the pointer. */
7963 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7969 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7970 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7972 lsize
= gfc_evaluate_now (lsize
, &block
);
7973 rsize
= gfc_evaluate_now (rsize
, &block
);
7974 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7977 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7978 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7982 gfc_add_block_to_block (&block
, &lse
.post
);
7984 gfc_add_block_to_block (&block
, &rse
.post
);
7987 return gfc_finish_block (&block
);
7991 /* Makes sure se is suitable for passing as a function string parameter. */
7992 /* TODO: Need to check all callers of this function. It may be abused. */
7995 gfc_conv_string_parameter (gfc_se
* se
)
7999 if (TREE_CODE (se
->expr
) == STRING_CST
)
8001 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8002 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8006 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8008 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8010 type
= TREE_TYPE (se
->expr
);
8011 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8015 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8017 type
= build_pointer_type (type
);
8018 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8022 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8026 /* Generate code for assignment of scalar variables. Includes character
8027 strings and derived types with allocatable components.
8028 If you know that the LHS has no allocations, set dealloc to false.
8030 DEEP_COPY has no effect if the typespec TS is not a derived type with
8031 allocatable components. Otherwise, if it is set, an explicit copy of each
8032 allocatable component is made. This is necessary as a simple copy of the
8033 whole object would copy array descriptors as is, so that the lhs's
8034 allocatable components would point to the rhs's after the assignment.
8035 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8036 necessary if the rhs is a non-pointer function, as the allocatable components
8037 are not accessible by other means than the function's result after the
8038 function has returned. It is even more subtle when temporaries are involved,
8039 as the two following examples show:
8040 1. When we evaluate an array constructor, a temporary is created. Thus
8041 there is theoretically no alias possible. However, no deep copy is
8042 made for this temporary, so that if the constructor is made of one or
8043 more variable with allocatable components, those components still point
8044 to the variable's: DEEP_COPY should be set for the assignment from the
8045 temporary to the lhs in that case.
8046 2. When assigning a scalar to an array, we evaluate the scalar value out
8047 of the loop, store it into a temporary variable, and assign from that.
8048 In that case, deep copying when assigning to the temporary would be a
8049 waste of resources; however deep copies should happen when assigning from
8050 the temporary to each array element: again DEEP_COPY should be set for
8051 the assignment from the temporary to the lhs. */
8054 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8055 bool l_is_temp
, bool deep_copy
, bool dealloc
)
8061 gfc_init_block (&block
);
8063 if (ts
.type
== BT_CHARACTER
)
8068 if (lse
->string_length
!= NULL_TREE
)
8070 gfc_conv_string_parameter (lse
);
8071 gfc_add_block_to_block (&block
, &lse
->pre
);
8072 llen
= lse
->string_length
;
8075 if (rse
->string_length
!= NULL_TREE
)
8077 gcc_assert (rse
->string_length
!= NULL_TREE
);
8078 gfc_conv_string_parameter (rse
);
8079 gfc_add_block_to_block (&block
, &rse
->pre
);
8080 rlen
= rse
->string_length
;
8083 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8084 rse
->expr
, ts
.kind
);
8086 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8088 tree tmp_var
= NULL_TREE
;
8091 /* Are the rhs and the lhs the same? */
8094 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8095 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8096 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8097 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8100 /* Deallocate the lhs allocated components as long as it is not
8101 the same as the rhs. This must be done following the assignment
8102 to prevent deallocating data that could be used in the rhs
8104 if (!l_is_temp
&& dealloc
)
8106 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8107 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8109 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8111 gfc_add_expr_to_block (&lse
->post
, tmp
);
8114 gfc_add_block_to_block (&block
, &rse
->pre
);
8115 gfc_add_block_to_block (&block
, &lse
->pre
);
8117 gfc_add_modify (&block
, lse
->expr
,
8118 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8120 /* Restore pointer address of coarray components. */
8121 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8123 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8124 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8126 gfc_add_expr_to_block (&block
, tmp
);
8129 /* Do a deep copy if the rhs is a variable, if it is not the
8133 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8134 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8136 gfc_add_expr_to_block (&block
, tmp
);
8139 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8141 gfc_add_block_to_block (&block
, &lse
->pre
);
8142 gfc_add_block_to_block (&block
, &rse
->pre
);
8143 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8144 TREE_TYPE (lse
->expr
), rse
->expr
);
8145 gfc_add_modify (&block
, lse
->expr
, tmp
);
8149 gfc_add_block_to_block (&block
, &lse
->pre
);
8150 gfc_add_block_to_block (&block
, &rse
->pre
);
8152 gfc_add_modify (&block
, lse
->expr
,
8153 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8156 gfc_add_block_to_block (&block
, &lse
->post
);
8157 gfc_add_block_to_block (&block
, &rse
->post
);
8159 return gfc_finish_block (&block
);
8163 /* There are quite a lot of restrictions on the optimisation in using an
8164 array function assign without a temporary. */
8167 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8170 bool seen_array_ref
;
8172 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8174 /* Play it safe with class functions assigned to a derived type. */
8175 if (gfc_is_alloc_class_array_function (expr2
)
8176 && expr1
->ts
.type
== BT_DERIVED
)
8179 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8180 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8183 /* Elemental functions are scalarized so that they don't need a
8184 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8185 they would need special treatment in gfc_trans_arrayfunc_assign. */
8186 if (expr2
->value
.function
.esym
!= NULL
8187 && expr2
->value
.function
.esym
->attr
.elemental
)
8190 /* Need a temporary if rhs is not FULL or a contiguous section. */
8191 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8194 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8195 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8198 /* Functions returning pointers or allocatables need temporaries. */
8199 c
= expr2
->value
.function
.esym
8200 ? (expr2
->value
.function
.esym
->attr
.pointer
8201 || expr2
->value
.function
.esym
->attr
.allocatable
)
8202 : (expr2
->symtree
->n
.sym
->attr
.pointer
8203 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8207 /* Character array functions need temporaries unless the
8208 character lengths are the same. */
8209 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8211 if (expr1
->ts
.u
.cl
->length
== NULL
8212 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8215 if (expr2
->ts
.u
.cl
->length
== NULL
8216 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8219 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8220 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8224 /* Check that no LHS component references appear during an array
8225 reference. This is needed because we do not have the means to
8226 span any arbitrary stride with an array descriptor. This check
8227 is not needed for the rhs because the function result has to be
8229 seen_array_ref
= false;
8230 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8232 if (ref
->type
== REF_ARRAY
)
8233 seen_array_ref
= true;
8234 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8238 /* Check for a dependency. */
8239 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8240 expr2
->value
.function
.esym
,
8241 expr2
->value
.function
.actual
,
8245 /* If we have reached here with an intrinsic function, we do not
8246 need a temporary except in the particular case that reallocation
8247 on assignment is active and the lhs is allocatable and a target. */
8248 if (expr2
->value
.function
.isym
)
8249 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8251 /* If the LHS is a dummy, we need a temporary if it is not
8253 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8256 /* If the lhs has been host_associated, is in common, a pointer or is
8257 a target and the function is not using a RESULT variable, aliasing
8258 can occur and a temporary is needed. */
8259 if ((sym
->attr
.host_assoc
8260 || sym
->attr
.in_common
8261 || sym
->attr
.pointer
8262 || sym
->attr
.cray_pointee
8263 || sym
->attr
.target
)
8264 && expr2
->symtree
!= NULL
8265 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8268 /* A PURE function can unconditionally be called without a temporary. */
8269 if (expr2
->value
.function
.esym
!= NULL
8270 && expr2
->value
.function
.esym
->attr
.pure
)
8273 /* Implicit_pure functions are those which could legally be declared
8275 if (expr2
->value
.function
.esym
!= NULL
8276 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8279 if (!sym
->attr
.use_assoc
8280 && !sym
->attr
.in_common
8281 && !sym
->attr
.pointer
8282 && !sym
->attr
.target
8283 && !sym
->attr
.cray_pointee
8284 && expr2
->value
.function
.esym
)
8286 /* A temporary is not needed if the function is not contained and
8287 the variable is local or host associated and not a pointer or
8289 if (!expr2
->value
.function
.esym
->attr
.contained
)
8292 /* A temporary is not needed if the lhs has never been host
8293 associated and the procedure is contained. */
8294 else if (!sym
->attr
.host_assoc
)
8297 /* A temporary is not needed if the variable is local and not
8298 a pointer, a target or a result. */
8300 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8304 /* Default to temporary use. */
8309 /* Provide the loop info so that the lhs descriptor can be built for
8310 reallocatable assignments from extrinsic function calls. */
8313 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8316 /* Signal that the function call should not be made by
8317 gfc_conv_loop_setup. */
8318 se
->ss
->is_alloc_lhs
= 1;
8319 gfc_init_loopinfo (loop
);
8320 gfc_add_ss_to_loop (loop
, *ss
);
8321 gfc_add_ss_to_loop (loop
, se
->ss
);
8322 gfc_conv_ss_startstride (loop
);
8323 gfc_conv_loop_setup (loop
, where
);
8324 gfc_copy_loopinfo_to_se (se
, loop
);
8325 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8326 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8327 se
->ss
->is_alloc_lhs
= 0;
8331 /* For assignment to a reallocatable lhs from intrinsic functions,
8332 replace the se.expr (ie. the result) with a temporary descriptor.
8333 Null the data field so that the library allocates space for the
8334 result. Free the data of the original descriptor after the function,
8335 in case it appears in an argument expression and transfer the
8336 result to the original descriptor. */
8339 fcncall_realloc_result (gfc_se
*se
, int rank
)
8348 /* Use the allocation done by the library. Substitute the lhs
8349 descriptor with a copy, whose data field is nulled.*/
8350 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8351 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8352 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8354 /* Unallocated, the descriptor does not have a dtype. */
8355 tmp
= gfc_conv_descriptor_dtype (desc
);
8356 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8358 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8359 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8360 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8362 /* Free the lhs after the function call and copy the result data to
8363 the lhs descriptor. */
8364 tmp
= gfc_conv_descriptor_data_get (desc
);
8365 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8366 boolean_type_node
, tmp
,
8367 build_int_cst (TREE_TYPE (tmp
), 0));
8368 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8369 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
8370 gfc_add_expr_to_block (&se
->post
, tmp
);
8372 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8373 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8375 /* Check that the shapes are the same between lhs and expression. */
8376 for (n
= 0 ; n
< rank
; n
++)
8379 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8380 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8381 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8382 gfc_array_index_type
, tmp
, tmp1
);
8383 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8384 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8385 gfc_array_index_type
, tmp
, tmp1
);
8386 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8387 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8388 gfc_array_index_type
, tmp
, tmp1
);
8389 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8390 boolean_type_node
, tmp
,
8391 gfc_index_zero_node
);
8392 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8393 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8394 boolean_type_node
, tmp
,
8398 /* 'zero_cond' being true is equal to lhs not being allocated or the
8399 shapes being different. */
8400 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8402 /* Now reset the bounds returned from the function call to bounds based
8403 on the lhs lbounds, except where the lhs is not allocated or the shapes
8404 of 'variable and 'expr' are different. Set the offset accordingly. */
8405 offset
= gfc_index_zero_node
;
8406 for (n
= 0 ; n
< rank
; n
++)
8410 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8411 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8412 gfc_array_index_type
, zero_cond
,
8413 gfc_index_one_node
, lbound
);
8414 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8416 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8417 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8418 gfc_array_index_type
, tmp
, lbound
);
8419 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8420 gfc_rank_cst
[n
], lbound
);
8421 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8422 gfc_rank_cst
[n
], tmp
);
8424 /* Set stride and accumulate the offset. */
8425 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8426 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8427 gfc_rank_cst
[n
], tmp
);
8428 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8429 gfc_array_index_type
, lbound
, tmp
);
8430 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8431 gfc_array_index_type
, offset
, tmp
);
8432 offset
= gfc_evaluate_now (offset
, &se
->post
);
8435 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8440 /* Try to translate array(:) = func (...), where func is a transformational
8441 array function, without using a temporary. Returns NULL if this isn't the
8445 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8449 gfc_component
*comp
= NULL
;
8452 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8455 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8457 comp
= gfc_get_proc_ptr_comp (expr2
);
8458 gcc_assert (expr2
->value
.function
.isym
8459 || (comp
&& comp
->attr
.dimension
)
8460 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8461 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8463 gfc_init_se (&se
, NULL
);
8464 gfc_start_block (&se
.pre
);
8465 se
.want_pointer
= 1;
8467 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8469 if (expr1
->ts
.type
== BT_DERIVED
8470 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8473 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8475 gfc_add_expr_to_block (&se
.pre
, tmp
);
8478 se
.direct_byref
= 1;
8479 se
.ss
= gfc_walk_expr (expr2
);
8480 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8482 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8483 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8484 Clearly, this cannot be done for an allocatable function result, since
8485 the shape of the result is unknown and, in any case, the function must
8486 correctly take care of the reallocation internally. For intrinsic
8487 calls, the array data is freed and the library takes care of allocation.
8488 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8490 if (flag_realloc_lhs
8491 && gfc_is_reallocatable_lhs (expr1
)
8492 && !gfc_expr_attr (expr1
).codimension
8493 && !gfc_is_coindexed (expr1
)
8494 && !(expr2
->value
.function
.esym
8495 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8497 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8499 if (!expr2
->value
.function
.isym
)
8501 ss
= gfc_walk_expr (expr1
);
8502 gcc_assert (ss
!= gfc_ss_terminator
);
8504 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8505 ss
->is_alloc_lhs
= 1;
8508 fcncall_realloc_result (&se
, expr1
->rank
);
8511 gfc_conv_function_expr (&se
, expr2
);
8512 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8515 gfc_cleanup_loop (&loop
);
8517 gfc_free_ss_chain (se
.ss
);
8519 return gfc_finish_block (&se
.pre
);
8523 /* Try to efficiently translate array(:) = 0. Return NULL if this
8527 gfc_trans_zero_assign (gfc_expr
* expr
)
8529 tree dest
, len
, type
;
8533 sym
= expr
->symtree
->n
.sym
;
8534 dest
= gfc_get_symbol_decl (sym
);
8536 type
= TREE_TYPE (dest
);
8537 if (POINTER_TYPE_P (type
))
8538 type
= TREE_TYPE (type
);
8539 if (!GFC_ARRAY_TYPE_P (type
))
8542 /* Determine the length of the array. */
8543 len
= GFC_TYPE_ARRAY_SIZE (type
);
8544 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8547 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8548 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8549 fold_convert (gfc_array_index_type
, tmp
));
8551 /* If we are zeroing a local array avoid taking its address by emitting
8553 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8554 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8555 dest
, build_constructor (TREE_TYPE (dest
),
8558 /* Convert arguments to the correct types. */
8559 dest
= fold_convert (pvoid_type_node
, dest
);
8560 len
= fold_convert (size_type_node
, len
);
8562 /* Construct call to __builtin_memset. */
8563 tmp
= build_call_expr_loc (input_location
,
8564 builtin_decl_explicit (BUILT_IN_MEMSET
),
8565 3, dest
, integer_zero_node
, len
);
8566 return fold_convert (void_type_node
, tmp
);
8570 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8571 that constructs the call to __builtin_memcpy. */
8574 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8578 /* Convert arguments to the correct types. */
8579 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8580 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8582 dst
= fold_convert (pvoid_type_node
, dst
);
8584 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8585 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8587 src
= fold_convert (pvoid_type_node
, src
);
8589 len
= fold_convert (size_type_node
, len
);
8591 /* Construct call to __builtin_memcpy. */
8592 tmp
= build_call_expr_loc (input_location
,
8593 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8595 return fold_convert (void_type_node
, tmp
);
8599 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8600 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8601 source/rhs, both are gfc_full_array_ref_p which have been checked for
8605 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8607 tree dst
, dlen
, dtype
;
8608 tree src
, slen
, stype
;
8611 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8612 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8614 dtype
= TREE_TYPE (dst
);
8615 if (POINTER_TYPE_P (dtype
))
8616 dtype
= TREE_TYPE (dtype
);
8617 stype
= TREE_TYPE (src
);
8618 if (POINTER_TYPE_P (stype
))
8619 stype
= TREE_TYPE (stype
);
8621 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8624 /* Determine the lengths of the arrays. */
8625 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8626 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8628 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8629 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8630 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8632 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8633 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8635 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8636 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8637 slen
, fold_convert (gfc_array_index_type
, tmp
));
8639 /* Sanity check that they are the same. This should always be
8640 the case, as we should already have checked for conformance. */
8641 if (!tree_int_cst_equal (slen
, dlen
))
8644 return gfc_build_memcpy_call (dst
, src
, dlen
);
8648 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8649 this can't be done. EXPR1 is the destination/lhs for which
8650 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8653 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8655 unsigned HOST_WIDE_INT nelem
;
8661 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8665 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8666 dtype
= TREE_TYPE (dst
);
8667 if (POINTER_TYPE_P (dtype
))
8668 dtype
= TREE_TYPE (dtype
);
8669 if (!GFC_ARRAY_TYPE_P (dtype
))
8672 /* Determine the lengths of the array. */
8673 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8674 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8677 /* Confirm that the constructor is the same size. */
8678 if (compare_tree_int (len
, nelem
) != 0)
8681 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8682 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8683 fold_convert (gfc_array_index_type
, tmp
));
8685 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8686 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8688 stype
= TREE_TYPE (src
);
8689 if (POINTER_TYPE_P (stype
))
8690 stype
= TREE_TYPE (stype
);
8692 return gfc_build_memcpy_call (dst
, src
, len
);
8696 /* Tells whether the expression is to be treated as a variable reference. */
8699 expr_is_variable (gfc_expr
*expr
)
8702 gfc_component
*comp
;
8703 gfc_symbol
*func_ifc
;
8705 if (expr
->expr_type
== EXPR_VARIABLE
)
8708 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8711 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8712 return expr_is_variable (arg
);
8715 /* A data-pointer-returning function should be considered as a variable
8717 if (expr
->expr_type
== EXPR_FUNCTION
8718 && expr
->ref
== NULL
)
8720 if (expr
->value
.function
.isym
!= NULL
)
8723 if (expr
->value
.function
.esym
!= NULL
)
8725 func_ifc
= expr
->value
.function
.esym
;
8730 gcc_assert (expr
->symtree
);
8731 func_ifc
= expr
->symtree
->n
.sym
;
8738 comp
= gfc_get_proc_ptr_comp (expr
);
8739 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8742 func_ifc
= comp
->ts
.interface
;
8746 if (expr
->expr_type
== EXPR_COMPCALL
)
8748 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8749 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8756 gcc_assert (func_ifc
->attr
.function
8757 && func_ifc
->result
!= NULL
);
8758 return func_ifc
->result
->attr
.pointer
;
8762 /* Is the lhs OK for automatic reallocation? */
8765 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8769 /* An allocatable variable with no reference. */
8770 if (expr
->symtree
->n
.sym
->attr
.allocatable
8774 /* All that can be left are allocatable components. */
8775 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8776 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8777 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8780 /* Find an allocatable component ref last. */
8781 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8782 if (ref
->type
== REF_COMPONENT
8784 && ref
->u
.c
.component
->attr
.allocatable
)
8791 /* Allocate or reallocate scalar lhs, as necessary. */
8794 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8808 if (!expr1
|| expr1
->rank
)
8811 if (!expr2
|| expr2
->rank
)
8814 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8816 /* Since this is a scalar lhs, we can afford to do this. That is,
8817 there is no risk of side effects being repeated. */
8818 gfc_init_se (&lse
, NULL
);
8819 lse
.want_pointer
= 1;
8820 gfc_conv_expr (&lse
, expr1
);
8822 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8823 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8825 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8826 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8827 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8829 tmp
= build3_v (COND_EXPR
, cond
,
8830 build1_v (GOTO_EXPR
, jump_label1
),
8831 build_empty_stmt (input_location
));
8832 gfc_add_expr_to_block (block
, tmp
);
8834 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8836 /* Use the rhs string length and the lhs element size. */
8837 size
= string_length
;
8838 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8839 tmp
= TYPE_SIZE_UNIT (tmp
);
8840 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8841 TREE_TYPE (tmp
), tmp
,
8842 fold_convert (TREE_TYPE (tmp
), size
));
8846 /* Otherwise use the length in bytes of the rhs. */
8847 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8848 size_in_bytes
= size
;
8851 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8852 size_in_bytes
, size_one_node
);
8854 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8856 tmp
= build_call_expr_loc (input_location
,
8857 builtin_decl_explicit (BUILT_IN_CALLOC
),
8858 2, build_one_cst (size_type_node
),
8860 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8861 gfc_add_modify (block
, lse
.expr
, tmp
);
8865 tmp
= build_call_expr_loc (input_location
,
8866 builtin_decl_explicit (BUILT_IN_MALLOC
),
8868 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8869 gfc_add_modify (block
, lse
.expr
, tmp
);
8872 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8874 /* Deferred characters need checking for lhs and rhs string
8875 length. Other deferred parameter variables will have to
8877 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8878 gfc_add_expr_to_block (block
, tmp
);
8880 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8881 gfc_add_expr_to_block (block
, tmp
);
8883 /* For a deferred length character, reallocate if lengths of lhs and
8884 rhs are different. */
8885 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8887 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8888 lse
.string_length
, size
);
8889 /* Jump past the realloc if the lengths are the same. */
8890 tmp
= build3_v (COND_EXPR
, cond
,
8891 build1_v (GOTO_EXPR
, jump_label2
),
8892 build_empty_stmt (input_location
));
8893 gfc_add_expr_to_block (block
, tmp
);
8894 tmp
= build_call_expr_loc (input_location
,
8895 builtin_decl_explicit (BUILT_IN_REALLOC
),
8896 2, fold_convert (pvoid_type_node
, lse
.expr
),
8898 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8899 gfc_add_modify (block
, lse
.expr
, tmp
);
8900 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8901 gfc_add_expr_to_block (block
, tmp
);
8903 /* Update the lhs character length. */
8904 size
= string_length
;
8905 gfc_add_modify (block
, lse
.string_length
, size
);
8909 /* Check for assignments of the type
8913 to make sure we do not check for reallocation unneccessarily. */
8917 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8919 gfc_actual_arglist
*a
;
8922 switch (expr2
->expr_type
)
8925 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8928 if (expr2
->value
.function
.esym
8929 && expr2
->value
.function
.esym
->attr
.elemental
)
8931 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8934 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8939 else if (expr2
->value
.function
.isym
8940 && expr2
->value
.function
.isym
->elemental
)
8942 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8945 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8954 switch (expr2
->value
.op
.op
)
8957 case INTRINSIC_UPLUS
:
8958 case INTRINSIC_UMINUS
:
8959 case INTRINSIC_PARENTHESES
:
8960 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8962 case INTRINSIC_PLUS
:
8963 case INTRINSIC_MINUS
:
8964 case INTRINSIC_TIMES
:
8965 case INTRINSIC_DIVIDE
:
8966 case INTRINSIC_POWER
:
8970 case INTRINSIC_NEQV
:
8977 case INTRINSIC_EQ_OS
:
8978 case INTRINSIC_NE_OS
:
8979 case INTRINSIC_GT_OS
:
8980 case INTRINSIC_GE_OS
:
8981 case INTRINSIC_LT_OS
:
8982 case INTRINSIC_LE_OS
:
8984 e1
= expr2
->value
.op
.op1
;
8985 e2
= expr2
->value
.op
.op2
;
8987 if (e1
->rank
== 0 && e2
->rank
> 0)
8988 return is_runtime_conformable (expr1
, e2
);
8989 else if (e1
->rank
> 0 && e2
->rank
== 0)
8990 return is_runtime_conformable (expr1
, e1
);
8991 else if (e1
->rank
> 0 && e2
->rank
> 0)
8992 return is_runtime_conformable (expr1
, e1
)
8993 && is_runtime_conformable (expr1
, e2
);
9009 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9010 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9011 init_flag indicates initialization expressions and dealloc that no
9012 deallocate prior assignment is needed (if in doubt, set true). */
9015 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9021 gfc_ss
*lss_section
;
9028 bool scalar_to_array
;
9032 /* Assignment of the form lhs = rhs. */
9033 gfc_start_block (&block
);
9035 gfc_init_se (&lse
, NULL
);
9036 gfc_init_se (&rse
, NULL
);
9039 lss
= gfc_walk_expr (expr1
);
9040 if (gfc_is_reallocatable_lhs (expr1
)
9041 && !(expr2
->expr_type
== EXPR_FUNCTION
9042 && expr2
->value
.function
.isym
!= NULL
))
9043 lss
->is_alloc_lhs
= 1;
9046 if ((expr1
->ts
.type
== BT_DERIVED
)
9047 && (gfc_is_alloc_class_array_function (expr2
)
9048 || gfc_is_alloc_class_scalar_function (expr2
)))
9049 expr2
->must_finalize
= 1;
9051 if (lss
!= gfc_ss_terminator
)
9053 /* The assignment needs scalarization. */
9056 /* Find a non-scalar SS from the lhs. */
9057 while (lss_section
!= gfc_ss_terminator
9058 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9059 lss_section
= lss_section
->next
;
9061 gcc_assert (lss_section
!= gfc_ss_terminator
);
9063 /* Initialize the scalarizer. */
9064 gfc_init_loopinfo (&loop
);
9067 rss
= gfc_walk_expr (expr2
);
9068 if (rss
== gfc_ss_terminator
)
9069 /* The rhs is scalar. Add a ss for the expression. */
9070 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9072 /* Associate the SS with the loop. */
9073 gfc_add_ss_to_loop (&loop
, lss
);
9074 gfc_add_ss_to_loop (&loop
, rss
);
9076 /* Calculate the bounds of the scalarization. */
9077 gfc_conv_ss_startstride (&loop
);
9078 /* Enable loop reversal. */
9079 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9080 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9081 /* Resolve any data dependencies in the statement. */
9082 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9083 /* Setup the scalarizing loops. */
9084 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9086 /* Setup the gfc_se structures. */
9087 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9088 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9091 gfc_mark_ss_chain_used (rss
, 1);
9092 if (loop
.temp_ss
== NULL
)
9095 gfc_mark_ss_chain_used (lss
, 1);
9099 lse
.ss
= loop
.temp_ss
;
9100 gfc_mark_ss_chain_used (lss
, 3);
9101 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9104 /* Allow the scalarizer to workshare array assignments. */
9105 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9106 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9108 /* Start the scalarized loop body. */
9109 gfc_start_scalarized_body (&loop
, &body
);
9112 gfc_init_block (&body
);
9114 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9116 /* Translate the expression. */
9117 gfc_conv_expr (&rse
, expr2
);
9119 /* Deal with the case of a scalar class function assigned to a derived type. */
9120 if (gfc_is_alloc_class_scalar_function (expr2
)
9121 && expr1
->ts
.type
== BT_DERIVED
)
9123 rse
.expr
= gfc_class_data_get (rse
.expr
);
9124 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9127 /* Stabilize a string length for temporaries. */
9128 if (expr2
->ts
.type
== BT_CHARACTER
)
9129 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9131 string_length
= NULL_TREE
;
9135 gfc_conv_tmp_array_ref (&lse
);
9136 if (expr2
->ts
.type
== BT_CHARACTER
)
9137 lse
.string_length
= string_length
;
9140 gfc_conv_expr (&lse
, expr1
);
9142 /* Assignments of scalar derived types with allocatable components
9143 to arrays must be done with a deep copy and the rhs temporary
9144 must have its components deallocated afterwards. */
9145 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9146 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9147 && !expr_is_variable (expr2
)
9148 && !gfc_is_constant_expr (expr2
)
9149 && expr1
->rank
&& !expr2
->rank
);
9150 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9152 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9153 && gfc_is_alloc_class_scalar_function (expr2
));
9154 if (scalar_to_array
&& dealloc
)
9156 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9157 gfc_add_expr_to_block (&loop
.post
, tmp
);
9160 /* When assigning a character function result to a deferred-length variable,
9161 the function call must happen before the (re)allocation of the lhs -
9162 otherwise the character length of the result is not known.
9163 NOTE: This relies on having the exact dependence of the length type
9164 parameter available to the caller; gfortran saves it in the .mod files. */
9165 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9166 gfc_add_block_to_block (&block
, &rse
.pre
);
9168 /* Nullify the allocatable components corresponding to those of the lhs
9169 derived type, so that the finalization of the function result does not
9170 affect the lhs of the assignment. Prepend is used to ensure that the
9171 nullification occurs before the call to the finalizer. In the case of
9172 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9173 as part of the deep copy. */
9174 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9175 && (gfc_is_alloc_class_array_function (expr2
)
9176 || gfc_is_alloc_class_scalar_function (expr2
)))
9179 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9180 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9181 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9182 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9185 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9186 l_is_temp
|| init_flag
,
9187 expr_is_variable (expr2
) || scalar_to_array
9188 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
9189 gfc_add_expr_to_block (&body
, tmp
);
9191 if (lss
== gfc_ss_terminator
)
9193 /* F2003: Add the code for reallocation on assignment. */
9194 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9195 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9198 /* Use the scalar assignment as is. */
9199 gfc_add_block_to_block (&block
, &body
);
9203 gcc_assert (lse
.ss
== gfc_ss_terminator
9204 && rse
.ss
== gfc_ss_terminator
);
9208 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9210 /* We need to copy the temporary to the actual lhs. */
9211 gfc_init_se (&lse
, NULL
);
9212 gfc_init_se (&rse
, NULL
);
9213 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9214 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9216 rse
.ss
= loop
.temp_ss
;
9219 gfc_conv_tmp_array_ref (&rse
);
9220 gfc_conv_expr (&lse
, expr1
);
9222 gcc_assert (lse
.ss
== gfc_ss_terminator
9223 && rse
.ss
== gfc_ss_terminator
);
9225 if (expr2
->ts
.type
== BT_CHARACTER
)
9226 rse
.string_length
= string_length
;
9228 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9229 false, false, dealloc
);
9230 gfc_add_expr_to_block (&body
, tmp
);
9233 /* F2003: Allocate or reallocate lhs of allocatable array. */
9234 if (flag_realloc_lhs
9235 && gfc_is_reallocatable_lhs (expr1
)
9236 && !gfc_expr_attr (expr1
).codimension
9237 && !gfc_is_coindexed (expr1
)
9239 && !is_runtime_conformable (expr1
, expr2
))
9241 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9242 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9243 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9244 if (tmp
!= NULL_TREE
)
9245 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9248 /* Generate the copying loops. */
9249 gfc_trans_scalarizing_loops (&loop
, &body
);
9251 /* Wrap the whole thing up. */
9252 gfc_add_block_to_block (&block
, &loop
.pre
);
9253 gfc_add_block_to_block (&block
, &loop
.post
);
9255 gfc_cleanup_loop (&loop
);
9258 return gfc_finish_block (&block
);
9262 /* Check whether EXPR is a copyable array. */
9265 copyable_array_p (gfc_expr
* expr
)
9267 if (expr
->expr_type
!= EXPR_VARIABLE
)
9270 /* First check it's an array. */
9271 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9274 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9277 /* Next check that it's of a simple enough type. */
9278 switch (expr
->ts
.type
)
9290 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9299 /* Translate an assignment. */
9302 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9307 /* Special case a single function returning an array. */
9308 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9310 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9315 /* Special case assigning an array to zero. */
9316 if (copyable_array_p (expr1
)
9317 && is_zero_initializer_p (expr2
))
9319 tmp
= gfc_trans_zero_assign (expr1
);
9324 /* Special case copying one array to another. */
9325 if (copyable_array_p (expr1
)
9326 && copyable_array_p (expr2
)
9327 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9328 && !gfc_check_dependency (expr1
, expr2
, 0))
9330 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9335 /* Special case initializing an array from a constant array constructor. */
9336 if (copyable_array_p (expr1
)
9337 && expr2
->expr_type
== EXPR_ARRAY
9338 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9340 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9345 /* Fallback to the scalarizer to generate explicit loops. */
9346 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9350 gfc_trans_init_assign (gfc_code
* code
)
9352 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9356 gfc_trans_assign (gfc_code
* code
)
9358 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);