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
)
2533 || !CLASS_DATA (sym
)->attr
.allocatable
)
2534 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2535 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2542 /* For character variables, also get the length. */
2543 if (sym
->ts
.type
== BT_CHARACTER
)
2545 /* If the character length of an entry isn't set, get the length from
2546 the master function instead. */
2547 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2548 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2550 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2551 gcc_assert (se
->string_length
);
2559 /* Return the descriptor if that's what we want and this is an array
2560 section reference. */
2561 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2563 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2564 /* Return the descriptor for array pointers and allocations. */
2565 if (se
->want_pointer
2566 && ref
->next
== NULL
&& (se
->descriptor_only
))
2569 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2570 /* Return a pointer to an element. */
2574 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2575 && se
->descriptor_only
2576 && !CLASS_DATA (sym
)->attr
.allocatable
2577 && !CLASS_DATA (sym
)->attr
.class_pointer
2578 && CLASS_DATA (sym
)->as
2579 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2580 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2581 /* Skip the first ref of a _data component, because for class
2582 arrays that one is already done by introducing a temporary
2583 array descriptor. */
2586 if (ref
->u
.c
.sym
->attr
.extension
)
2587 conv_parent_component_references (se
, ref
);
2589 gfc_conv_component_ref (se
, ref
);
2590 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2591 && se
->want_pointer
&& se
->descriptor_only
)
2597 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2598 expr
->symtree
->name
, &expr
->where
);
2608 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2610 if (se
->want_pointer
)
2612 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2613 gfc_conv_string_parameter (se
);
2615 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2620 /* Unary ops are easy... Or they would be if ! was a valid op. */
2623 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2628 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2629 /* Initialize the operand. */
2630 gfc_init_se (&operand
, se
);
2631 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2632 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2634 type
= gfc_typenode_for_spec (&expr
->ts
);
2636 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2637 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2638 All other unary operators have an equivalent GIMPLE unary operator. */
2639 if (code
== TRUTH_NOT_EXPR
)
2640 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2641 build_int_cst (type
, 0));
2643 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2647 /* Expand power operator to optimal multiplications when a value is raised
2648 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2649 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2650 Programming", 3rd Edition, 1998. */
2652 /* This code is mostly duplicated from expand_powi in the backend.
2653 We establish the "optimal power tree" lookup table with the defined size.
2654 The items in the table are the exponents used to calculate the index
2655 exponents. Any integer n less than the value can get an "addition chain",
2656 with the first node being one. */
2657 #define POWI_TABLE_SIZE 256
2659 /* The table is from builtins.c. */
2660 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2662 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2663 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2664 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2665 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2666 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2667 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2668 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2669 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2670 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2671 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2672 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2673 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2674 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2675 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2676 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2677 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2678 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2679 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2680 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2681 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2682 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2683 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2684 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2685 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2686 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2687 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2688 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2689 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2690 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2691 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2692 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2693 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2696 /* If n is larger than lookup table's max index, we use the "window
2698 #define POWI_WINDOW_SIZE 3
2700 /* Recursive function to expand the power operator. The temporary
2701 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2703 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2710 if (n
< POWI_TABLE_SIZE
)
2715 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2716 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2720 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2721 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2722 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2726 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2730 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2731 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2733 if (n
< POWI_TABLE_SIZE
)
2740 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2741 return 1. Else return 0 and a call to runtime library functions
2742 will have to be built. */
2744 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2749 tree vartmp
[POWI_TABLE_SIZE
];
2751 unsigned HOST_WIDE_INT n
;
2753 wide_int wrhs
= rhs
;
2755 /* If exponent is too large, we won't expand it anyway, so don't bother
2756 with large integer values. */
2757 if (!wi::fits_shwi_p (wrhs
))
2760 m
= wrhs
.to_shwi ();
2761 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2762 of the asymmetric range of the integer type. */
2763 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2765 type
= TREE_TYPE (lhs
);
2766 sgn
= tree_int_cst_sgn (rhs
);
2768 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2769 || optimize_size
) && (m
> 2 || m
< -1))
2775 se
->expr
= gfc_build_const (type
, integer_one_node
);
2779 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2780 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2782 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2783 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2784 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2785 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2788 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2791 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2792 boolean_type_node
, tmp
, cond
);
2793 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2794 tmp
, build_int_cst (type
, 1),
2795 build_int_cst (type
, 0));
2799 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2800 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2801 build_int_cst (type
, -1),
2802 build_int_cst (type
, 0));
2803 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2804 cond
, build_int_cst (type
, 1), tmp
);
2808 memset (vartmp
, 0, sizeof (vartmp
));
2812 tmp
= gfc_build_const (type
, integer_one_node
);
2813 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2817 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2823 /* Power op (**). Constant integer exponent has special handling. */
2826 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2828 tree gfc_int4_type_node
;
2831 int res_ikind_1
, res_ikind_2
;
2836 gfc_init_se (&lse
, se
);
2837 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2838 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2839 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2841 gfc_init_se (&rse
, se
);
2842 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2843 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2845 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2846 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2847 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2850 gfc_int4_type_node
= gfc_get_int_type (4);
2852 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2853 library routine. But in the end, we have to convert the result back
2854 if this case applies -- with res_ikind_K, we keep track whether operand K
2855 falls into this case. */
2859 kind
= expr
->value
.op
.op1
->ts
.kind
;
2860 switch (expr
->value
.op
.op2
->ts
.type
)
2863 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2868 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2869 res_ikind_2
= ikind
;
2891 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2893 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2920 switch (expr
->value
.op
.op1
->ts
.type
)
2923 if (kind
== 3) /* Case 16 was not handled properly above. */
2925 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2929 /* Use builtins for real ** int4. */
2935 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2939 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2943 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2947 /* Use the __builtin_powil() only if real(kind=16) is
2948 actually the C long double type. */
2949 if (!gfc_real16_is_float128
)
2950 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2958 /* If we don't have a good builtin for this, go for the
2959 library function. */
2961 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2965 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2974 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2978 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2986 se
->expr
= build_call_expr_loc (input_location
,
2987 fndecl
, 2, lse
.expr
, rse
.expr
);
2989 /* Convert the result back if it is of wrong integer kind. */
2990 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2992 /* We want the maximum of both operand kinds as result. */
2993 if (res_ikind_1
< res_ikind_2
)
2994 res_ikind_1
= res_ikind_2
;
2995 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3000 /* Generate code to allocate a string temporary. */
3003 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3008 if (gfc_can_put_var_on_stack (len
))
3010 /* Create a temporary variable to hold the result. */
3011 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3012 gfc_charlen_type_node
, len
,
3013 build_int_cst (gfc_charlen_type_node
, 1));
3014 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3016 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3017 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3019 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3021 var
= gfc_create_var (tmp
, "str");
3022 var
= gfc_build_addr_expr (type
, var
);
3026 /* Allocate a temporary to hold the result. */
3027 var
= gfc_create_var (type
, "pstr");
3028 gcc_assert (POINTER_TYPE_P (type
));
3029 tmp
= TREE_TYPE (type
);
3030 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3031 tmp
= TREE_TYPE (tmp
);
3032 tmp
= TYPE_SIZE_UNIT (tmp
);
3033 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3034 fold_convert (size_type_node
, len
),
3035 fold_convert (size_type_node
, tmp
));
3036 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3037 gfc_add_modify (&se
->pre
, var
, tmp
);
3039 /* Free the temporary afterwards. */
3040 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
3041 gfc_add_expr_to_block (&se
->post
, tmp
);
3048 /* Handle a string concatenation operation. A temporary will be allocated to
3052 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3055 tree len
, type
, var
, tmp
, fndecl
;
3057 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3058 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3059 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3061 gfc_init_se (&lse
, se
);
3062 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3063 gfc_conv_string_parameter (&lse
);
3064 gfc_init_se (&rse
, se
);
3065 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3066 gfc_conv_string_parameter (&rse
);
3068 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3069 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3071 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3072 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3073 if (len
== NULL_TREE
)
3075 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3076 TREE_TYPE (lse
.string_length
),
3077 lse
.string_length
, rse
.string_length
);
3080 type
= build_pointer_type (type
);
3082 var
= gfc_conv_string_tmp (se
, type
, len
);
3084 /* Do the actual concatenation. */
3085 if (expr
->ts
.kind
== 1)
3086 fndecl
= gfor_fndecl_concat_string
;
3087 else if (expr
->ts
.kind
== 4)
3088 fndecl
= gfor_fndecl_concat_string_char4
;
3092 tmp
= build_call_expr_loc (input_location
,
3093 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3094 rse
.string_length
, rse
.expr
);
3095 gfc_add_expr_to_block (&se
->pre
, tmp
);
3097 /* Add the cleanup for the operands. */
3098 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3099 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3102 se
->string_length
= len
;
3105 /* Translates an op expression. Common (binary) cases are handled by this
3106 function, others are passed on. Recursion is used in either case.
3107 We use the fact that (op1.ts == op2.ts) (except for the power
3109 Operators need no special handling for scalarized expressions as long as
3110 they call gfc_conv_simple_val to get their operands.
3111 Character strings get special handling. */
3114 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3116 enum tree_code code
;
3125 switch (expr
->value
.op
.op
)
3127 case INTRINSIC_PARENTHESES
:
3128 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3129 && flag_protect_parens
)
3131 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3132 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3137 case INTRINSIC_UPLUS
:
3138 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3141 case INTRINSIC_UMINUS
:
3142 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3146 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3149 case INTRINSIC_PLUS
:
3153 case INTRINSIC_MINUS
:
3157 case INTRINSIC_TIMES
:
3161 case INTRINSIC_DIVIDE
:
3162 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3163 an integer, we must round towards zero, so we use a
3165 if (expr
->ts
.type
== BT_INTEGER
)
3166 code
= TRUNC_DIV_EXPR
;
3171 case INTRINSIC_POWER
:
3172 gfc_conv_power_op (se
, expr
);
3175 case INTRINSIC_CONCAT
:
3176 gfc_conv_concat_op (se
, expr
);
3180 code
= TRUTH_ANDIF_EXPR
;
3185 code
= TRUTH_ORIF_EXPR
;
3189 /* EQV and NEQV only work on logicals, but since we represent them
3190 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3192 case INTRINSIC_EQ_OS
:
3200 case INTRINSIC_NE_OS
:
3201 case INTRINSIC_NEQV
:
3208 case INTRINSIC_GT_OS
:
3215 case INTRINSIC_GE_OS
:
3222 case INTRINSIC_LT_OS
:
3229 case INTRINSIC_LE_OS
:
3235 case INTRINSIC_USER
:
3236 case INTRINSIC_ASSIGN
:
3237 /* These should be converted into function calls by the frontend. */
3241 fatal_error (input_location
, "Unknown intrinsic op");
3245 /* The only exception to this is **, which is handled separately anyway. */
3246 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3248 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3252 gfc_init_se (&lse
, se
);
3253 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3254 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3257 gfc_init_se (&rse
, se
);
3258 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3259 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3263 gfc_conv_string_parameter (&lse
);
3264 gfc_conv_string_parameter (&rse
);
3266 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3267 rse
.string_length
, rse
.expr
,
3268 expr
->value
.op
.op1
->ts
.kind
,
3270 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3271 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3274 type
= gfc_typenode_for_spec (&expr
->ts
);
3278 /* The result of logical ops is always boolean_type_node. */
3279 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3280 lse
.expr
, rse
.expr
);
3281 se
->expr
= convert (type
, tmp
);
3284 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3286 /* Add the post blocks. */
3287 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3288 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3291 /* If a string's length is one, we convert it to a single character. */
3294 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3298 || !tree_fits_uhwi_p (len
)
3299 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3302 if (TREE_INT_CST_LOW (len
) == 1)
3304 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3305 return build_fold_indirect_ref_loc (input_location
, str
);
3309 && TREE_CODE (str
) == ADDR_EXPR
3310 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3311 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3312 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3313 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3314 && TREE_INT_CST_LOW (len
) > 1
3315 && TREE_INT_CST_LOW (len
)
3316 == (unsigned HOST_WIDE_INT
)
3317 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3319 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3320 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3321 if (TREE_CODE (ret
) == INTEGER_CST
)
3323 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3324 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3325 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3327 for (i
= 1; i
< length
; i
++)
3340 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3343 if (sym
->backend_decl
)
3345 /* This becomes the nominal_type in
3346 function.c:assign_parm_find_data_types. */
3347 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3348 /* This becomes the passed_type in
3349 function.c:assign_parm_find_data_types. C promotes char to
3350 integer for argument passing. */
3351 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3353 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3358 /* If we have a constant character expression, make it into an
3360 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3365 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3366 (int)(*expr
)->value
.character
.string
[0]);
3367 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3369 /* The expr needs to be compatible with a C int. If the
3370 conversion fails, then the 2 causes an ICE. */
3371 ts
.type
= BT_INTEGER
;
3372 ts
.kind
= gfc_c_int_kind
;
3373 gfc_convert_type (*expr
, &ts
, 2);
3376 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3378 if ((*expr
)->ref
== NULL
)
3380 se
->expr
= gfc_string_to_single_character
3381 (build_int_cst (integer_type_node
, 1),
3382 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3384 ((*expr
)->symtree
->n
.sym
)),
3389 gfc_conv_variable (se
, *expr
);
3390 se
->expr
= gfc_string_to_single_character
3391 (build_int_cst (integer_type_node
, 1),
3392 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3400 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3401 if STR is a string literal, otherwise return -1. */
3404 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3407 && TREE_CODE (str
) == ADDR_EXPR
3408 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3409 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3410 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3411 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3412 && tree_fits_uhwi_p (len
)
3413 && tree_to_uhwi (len
) >= 1
3414 && tree_to_uhwi (len
)
3415 == (unsigned HOST_WIDE_INT
)
3416 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3418 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3419 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3420 if (TREE_CODE (folded
) == INTEGER_CST
)
3422 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3423 int length
= TREE_STRING_LENGTH (string_cst
);
3424 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3426 for (; length
> 0; length
--)
3427 if (ptr
[length
- 1] != ' ')
3436 /* Helper to build a call to memcmp. */
3439 build_memcmp_call (tree s1
, tree s2
, tree n
)
3443 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3444 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3446 s1
= fold_convert (pvoid_type_node
, s1
);
3448 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3449 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3451 s2
= fold_convert (pvoid_type_node
, s2
);
3453 n
= fold_convert (size_type_node
, n
);
3455 tmp
= build_call_expr_loc (input_location
,
3456 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3459 return fold_convert (integer_type_node
, tmp
);
3462 /* Compare two strings. If they are all single characters, the result is the
3463 subtraction of them. Otherwise, we build a library call. */
3466 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3467 enum tree_code code
)
3473 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3474 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3476 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3477 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3479 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3481 /* Deal with single character specially. */
3482 sc1
= fold_convert (integer_type_node
, sc1
);
3483 sc2
= fold_convert (integer_type_node
, sc2
);
3484 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3488 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3490 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3492 /* If one string is a string literal with LEN_TRIM longer
3493 than the length of the second string, the strings
3495 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3496 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3497 return integer_one_node
;
3498 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3499 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3500 return integer_one_node
;
3503 /* We can compare via memcpy if the strings are known to be equal
3504 in length and they are
3506 - kind=4 and the comparison is for (in)equality. */
3508 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3509 && tree_int_cst_equal (len1
, len2
)
3510 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3515 chartype
= gfc_get_char_type (kind
);
3516 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3517 fold_convert (TREE_TYPE(len1
),
3518 TYPE_SIZE_UNIT(chartype
)),
3520 return build_memcmp_call (str1
, str2
, tmp
);
3523 /* Build a call for the comparison. */
3525 fndecl
= gfor_fndecl_compare_string
;
3527 fndecl
= gfor_fndecl_compare_string_char4
;
3531 return build_call_expr_loc (input_location
, fndecl
, 4,
3532 len1
, str1
, len2
, str2
);
3536 /* Return the backend_decl for a procedure pointer component. */
3539 get_proc_ptr_comp (gfc_expr
*e
)
3545 gfc_init_se (&comp_se
, NULL
);
3546 e2
= gfc_copy_expr (e
);
3547 /* We have to restore the expr type later so that gfc_free_expr frees
3548 the exact same thing that was allocated.
3549 TODO: This is ugly. */
3550 old_type
= e2
->expr_type
;
3551 e2
->expr_type
= EXPR_VARIABLE
;
3552 gfc_conv_expr (&comp_se
, e2
);
3553 e2
->expr_type
= old_type
;
3555 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3559 /* Convert a typebound function reference from a class object. */
3561 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3566 if (TREE_CODE (base_object
) != VAR_DECL
)
3568 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3569 gfc_add_modify (&se
->pre
, var
, base_object
);
3571 se
->expr
= gfc_class_vptr_get (base_object
);
3572 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3574 while (ref
&& ref
->next
)
3576 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3577 if (ref
->u
.c
.sym
->attr
.extension
)
3578 conv_parent_component_references (se
, ref
);
3579 gfc_conv_component_ref (se
, ref
);
3580 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3585 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3589 if (gfc_is_proc_ptr_comp (expr
))
3590 tmp
= get_proc_ptr_comp (expr
);
3591 else if (sym
->attr
.dummy
)
3593 tmp
= gfc_get_symbol_decl (sym
);
3594 if (sym
->attr
.proc_pointer
)
3595 tmp
= build_fold_indirect_ref_loc (input_location
,
3597 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3598 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3602 if (!sym
->backend_decl
)
3603 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3605 TREE_USED (sym
->backend_decl
) = 1;
3607 tmp
= sym
->backend_decl
;
3609 if (sym
->attr
.cray_pointee
)
3611 /* TODO - make the cray pointee a pointer to a procedure,
3612 assign the pointer to it and use it for the call. This
3614 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3615 gfc_get_symbol_decl (sym
->cp_pointer
));
3616 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3619 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3621 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3622 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3629 /* Initialize MAPPING. */
3632 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3634 mapping
->syms
= NULL
;
3635 mapping
->charlens
= NULL
;
3639 /* Free all memory held by MAPPING (but not MAPPING itself). */
3642 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3644 gfc_interface_sym_mapping
*sym
;
3645 gfc_interface_sym_mapping
*nextsym
;
3647 gfc_charlen
*nextcl
;
3649 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3651 nextsym
= sym
->next
;
3652 sym
->new_sym
->n
.sym
->formal
= NULL
;
3653 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3654 gfc_free_expr (sym
->expr
);
3655 free (sym
->new_sym
);
3658 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3661 gfc_free_expr (cl
->length
);
3667 /* Return a copy of gfc_charlen CL. Add the returned structure to
3668 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3670 static gfc_charlen
*
3671 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3674 gfc_charlen
*new_charlen
;
3676 new_charlen
= gfc_get_charlen ();
3677 new_charlen
->next
= mapping
->charlens
;
3678 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3680 mapping
->charlens
= new_charlen
;
3685 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3686 array variable that can be used as the actual argument for dummy
3687 argument SYM. Add any initialization code to BLOCK. PACKED is as
3688 for gfc_get_nodesc_array_type and DATA points to the first element
3689 in the passed array. */
3692 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3693 gfc_packed packed
, tree data
)
3698 type
= gfc_typenode_for_spec (&sym
->ts
);
3699 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3700 !sym
->attr
.target
&& !sym
->attr
.pointer
3701 && !sym
->attr
.proc_pointer
);
3703 var
= gfc_create_var (type
, "ifm");
3704 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3710 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3711 and offset of descriptorless array type TYPE given that it has the same
3712 size as DESC. Add any set-up code to BLOCK. */
3715 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3722 offset
= gfc_index_zero_node
;
3723 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3725 dim
= gfc_rank_cst
[n
];
3726 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3727 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3729 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3730 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3731 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3732 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3734 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3736 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3737 gfc_array_index_type
,
3738 gfc_conv_descriptor_ubound_get (desc
, dim
),
3739 gfc_conv_descriptor_lbound_get (desc
, dim
));
3740 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3741 gfc_array_index_type
,
3742 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3743 tmp
= gfc_evaluate_now (tmp
, block
);
3744 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3746 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3747 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3748 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3749 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3750 gfc_array_index_type
, offset
, tmp
);
3752 offset
= gfc_evaluate_now (offset
, block
);
3753 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3757 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3758 in SE. The caller may still use se->expr and se->string_length after
3759 calling this function. */
3762 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3763 gfc_symbol
* sym
, gfc_se
* se
,
3766 gfc_interface_sym_mapping
*sm
;
3770 gfc_symbol
*new_sym
;
3772 gfc_symtree
*new_symtree
;
3774 /* Create a new symbol to represent the actual argument. */
3775 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3776 new_sym
->ts
= sym
->ts
;
3777 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3778 new_sym
->attr
.referenced
= 1;
3779 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3780 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3781 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3782 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3783 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3784 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3785 new_sym
->attr
.function
= sym
->attr
.function
;
3787 /* Ensure that the interface is available and that
3788 descriptors are passed for array actual arguments. */
3789 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3791 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3792 new_sym
->attr
.always_explicit
3793 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3796 /* Create a fake symtree for it. */
3798 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3799 new_symtree
->n
.sym
= new_sym
;
3800 gcc_assert (new_symtree
== root
);
3802 /* Create a dummy->actual mapping. */
3803 sm
= XCNEW (gfc_interface_sym_mapping
);
3804 sm
->next
= mapping
->syms
;
3806 sm
->new_sym
= new_symtree
;
3807 sm
->expr
= gfc_copy_expr (expr
);
3810 /* Stabilize the argument's value. */
3811 if (!sym
->attr
.function
&& se
)
3812 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3814 if (sym
->ts
.type
== BT_CHARACTER
)
3816 /* Create a copy of the dummy argument's length. */
3817 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3818 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3820 /* If the length is specified as "*", record the length that
3821 the caller is passing. We should use the callee's length
3822 in all other cases. */
3823 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3825 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3826 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3833 /* Use the passed value as-is if the argument is a function. */
3834 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3837 /* If the argument is either a string or a pointer to a string,
3838 convert it to a boundless character type. */
3839 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3841 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3842 tmp
= build_pointer_type (tmp
);
3843 if (sym
->attr
.pointer
)
3844 value
= build_fold_indirect_ref_loc (input_location
,
3848 value
= fold_convert (tmp
, value
);
3851 /* If the argument is a scalar, a pointer to an array or an allocatable,
3853 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3854 value
= build_fold_indirect_ref_loc (input_location
,
3857 /* For character(*), use the actual argument's descriptor. */
3858 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3859 value
= build_fold_indirect_ref_loc (input_location
,
3862 /* If the argument is an array descriptor, use it to determine
3863 information about the actual argument's shape. */
3864 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3865 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3867 /* Get the actual argument's descriptor. */
3868 desc
= build_fold_indirect_ref_loc (input_location
,
3871 /* Create the replacement variable. */
3872 tmp
= gfc_conv_descriptor_data_get (desc
);
3873 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3876 /* Use DESC to work out the upper bounds, strides and offset. */
3877 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3880 /* Otherwise we have a packed array. */
3881 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3882 PACKED_FULL
, se
->expr
);
3884 new_sym
->backend_decl
= value
;
3888 /* Called once all dummy argument mappings have been added to MAPPING,
3889 but before the mapping is used to evaluate expressions. Pre-evaluate
3890 the length of each argument, adding any initialization code to PRE and
3891 any finalization code to POST. */
3894 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3895 stmtblock_t
* pre
, stmtblock_t
* post
)
3897 gfc_interface_sym_mapping
*sym
;
3901 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3902 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3903 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3905 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3906 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3907 gfc_init_se (&se
, NULL
);
3908 gfc_conv_expr (&se
, expr
);
3909 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3910 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3911 gfc_add_block_to_block (pre
, &se
.pre
);
3912 gfc_add_block_to_block (post
, &se
.post
);
3914 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3919 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3923 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3924 gfc_constructor_base base
)
3927 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3929 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3932 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3933 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3934 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3940 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3944 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3949 for (; ref
; ref
= ref
->next
)
3953 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3955 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3956 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3957 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3965 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3966 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3972 /* Convert intrinsic function calls into result expressions. */
3975 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3983 arg1
= expr
->value
.function
.actual
->expr
;
3984 if (expr
->value
.function
.actual
->next
)
3985 arg2
= expr
->value
.function
.actual
->next
->expr
;
3989 sym
= arg1
->symtree
->n
.sym
;
3991 if (sym
->attr
.dummy
)
3996 switch (expr
->value
.function
.isym
->id
)
3999 /* TODO figure out why this condition is necessary. */
4000 if (sym
->attr
.function
4001 && (arg1
->ts
.u
.cl
->length
== NULL
4002 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4003 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4006 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4010 if (!sym
->as
|| sym
->as
->rank
== 0)
4013 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4015 dup
= mpz_get_si (arg2
->value
.integer
);
4020 dup
= sym
->as
->rank
;
4024 for (; d
< dup
; d
++)
4028 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4030 gfc_free_expr (new_expr
);
4034 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4035 gfc_get_int_expr (gfc_default_integer_kind
,
4037 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4039 new_expr
= gfc_multiply (new_expr
, tmp
);
4045 case GFC_ISYM_LBOUND
:
4046 case GFC_ISYM_UBOUND
:
4047 /* TODO These implementations of lbound and ubound do not limit if
4048 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4050 if (!sym
->as
|| sym
->as
->rank
== 0)
4053 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4054 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4056 /* TODO: If the need arises, this could produce an array of
4060 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4062 if (sym
->as
->lower
[d
])
4063 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4067 if (sym
->as
->upper
[d
])
4068 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4076 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4080 gfc_replace_expr (expr
, new_expr
);
4086 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4087 gfc_interface_mapping
* mapping
)
4089 gfc_formal_arglist
*f
;
4090 gfc_actual_arglist
*actual
;
4092 actual
= expr
->value
.function
.actual
;
4093 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4095 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4100 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4103 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4108 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4110 for (d
= 0; d
< as
->rank
; d
++)
4112 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4113 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4116 expr
->value
.function
.esym
->as
= as
;
4119 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4121 expr
->value
.function
.esym
->ts
.u
.cl
->length
4122 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4124 gfc_apply_interface_mapping_to_expr (mapping
,
4125 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4130 /* EXPR is a copy of an expression that appeared in the interface
4131 associated with MAPPING. Walk it recursively looking for references to
4132 dummy arguments that MAPPING maps to actual arguments. Replace each such
4133 reference with a reference to the associated actual argument. */
4136 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4139 gfc_interface_sym_mapping
*sym
;
4140 gfc_actual_arglist
*actual
;
4145 /* Copying an expression does not copy its length, so do that here. */
4146 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4148 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4149 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4152 /* Apply the mapping to any references. */
4153 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4155 /* ...and to the expression's symbol, if it has one. */
4156 /* TODO Find out why the condition on expr->symtree had to be moved into
4157 the loop rather than being outside it, as originally. */
4158 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4159 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4161 if (sym
->new_sym
->n
.sym
->backend_decl
)
4162 expr
->symtree
= sym
->new_sym
;
4164 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4167 /* ...and to subexpressions in expr->value. */
4168 switch (expr
->expr_type
)
4173 case EXPR_SUBSTRING
:
4177 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4178 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4182 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4183 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4185 if (expr
->value
.function
.esym
== NULL
4186 && expr
->value
.function
.isym
!= NULL
4187 && expr
->value
.function
.actual
->expr
->symtree
4188 && gfc_map_intrinsic_function (expr
, mapping
))
4191 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4192 if (sym
->old
== expr
->value
.function
.esym
)
4194 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4195 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4196 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4201 case EXPR_STRUCTURE
:
4202 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4215 /* Evaluate interface expression EXPR using MAPPING. Store the result
4219 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4220 gfc_se
* se
, gfc_expr
* expr
)
4222 expr
= gfc_copy_expr (expr
);
4223 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4224 gfc_conv_expr (se
, expr
);
4225 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4226 gfc_free_expr (expr
);
4230 /* Returns a reference to a temporary array into which a component of
4231 an actual argument derived type array is copied and then returned
4232 after the function call. */
4234 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4235 sym_intent intent
, bool formal_ptr
)
4243 gfc_array_info
*info
;
4253 gfc_init_se (&lse
, NULL
);
4254 gfc_init_se (&rse
, NULL
);
4256 /* Walk the argument expression. */
4257 rss
= gfc_walk_expr (expr
);
4259 gcc_assert (rss
!= gfc_ss_terminator
);
4261 /* Initialize the scalarizer. */
4262 gfc_init_loopinfo (&loop
);
4263 gfc_add_ss_to_loop (&loop
, rss
);
4265 /* Calculate the bounds of the scalarization. */
4266 gfc_conv_ss_startstride (&loop
);
4268 /* Build an ss for the temporary. */
4269 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4270 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4272 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4273 if (GFC_ARRAY_TYPE_P (base_type
)
4274 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4275 base_type
= gfc_get_element_type (base_type
);
4277 if (expr
->ts
.type
== BT_CLASS
)
4278 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4280 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4281 ? expr
->ts
.u
.cl
->backend_decl
4285 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4287 /* Associate the SS with the loop. */
4288 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4290 /* Setup the scalarizing loops. */
4291 gfc_conv_loop_setup (&loop
, &expr
->where
);
4293 /* Pass the temporary descriptor back to the caller. */
4294 info
= &loop
.temp_ss
->info
->data
.array
;
4295 parmse
->expr
= info
->descriptor
;
4297 /* Setup the gfc_se structures. */
4298 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4299 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4302 lse
.ss
= loop
.temp_ss
;
4303 gfc_mark_ss_chain_used (rss
, 1);
4304 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4306 /* Start the scalarized loop body. */
4307 gfc_start_scalarized_body (&loop
, &body
);
4309 /* Translate the expression. */
4310 gfc_conv_expr (&rse
, expr
);
4312 /* Reset the offset for the function call since the loop
4313 is zero based on the data pointer. Note that the temp
4314 comes first in the loop chain since it is added second. */
4315 if (gfc_is_alloc_class_array_function (expr
))
4317 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4318 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4319 gfc_index_zero_node
);
4322 gfc_conv_tmp_array_ref (&lse
);
4324 if (intent
!= INTENT_OUT
)
4326 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
4327 gfc_add_expr_to_block (&body
, tmp
);
4328 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4329 gfc_trans_scalarizing_loops (&loop
, &body
);
4333 /* Make sure that the temporary declaration survives by merging
4334 all the loop declarations into the current context. */
4335 for (n
= 0; n
< loop
.dimen
; n
++)
4337 gfc_merge_block_scope (&body
);
4338 body
= loop
.code
[loop
.order
[n
]];
4340 gfc_merge_block_scope (&body
);
4343 /* Add the post block after the second loop, so that any
4344 freeing of allocated memory is done at the right time. */
4345 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4347 /**********Copy the temporary back again.*********/
4349 gfc_init_se (&lse
, NULL
);
4350 gfc_init_se (&rse
, NULL
);
4352 /* Walk the argument expression. */
4353 lss
= gfc_walk_expr (expr
);
4354 rse
.ss
= loop
.temp_ss
;
4357 /* Initialize the scalarizer. */
4358 gfc_init_loopinfo (&loop2
);
4359 gfc_add_ss_to_loop (&loop2
, lss
);
4361 dimen
= rse
.ss
->dimen
;
4363 /* Skip the write-out loop for this case. */
4364 if (gfc_is_alloc_class_array_function (expr
))
4365 goto class_array_fcn
;
4367 /* Calculate the bounds of the scalarization. */
4368 gfc_conv_ss_startstride (&loop2
);
4370 /* Setup the scalarizing loops. */
4371 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4373 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4374 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4376 gfc_mark_ss_chain_used (lss
, 1);
4377 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4379 /* Declare the variable to hold the temporary offset and start the
4380 scalarized loop body. */
4381 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4382 gfc_start_scalarized_body (&loop2
, &body
);
4384 /* Build the offsets for the temporary from the loop variables. The
4385 temporary array has lbounds of zero and strides of one in all
4386 dimensions, so this is very simple. The offset is only computed
4387 outside the innermost loop, so the overall transfer could be
4388 optimized further. */
4389 info
= &rse
.ss
->info
->data
.array
;
4391 tmp_index
= gfc_index_zero_node
;
4392 for (n
= dimen
- 1; n
> 0; n
--)
4395 tmp
= rse
.loop
->loopvar
[n
];
4396 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4397 tmp
, rse
.loop
->from
[n
]);
4398 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4401 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4402 gfc_array_index_type
,
4403 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4404 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4405 gfc_array_index_type
,
4406 tmp_str
, gfc_index_one_node
);
4408 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4409 gfc_array_index_type
, tmp
, tmp_str
);
4412 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4413 gfc_array_index_type
,
4414 tmp_index
, rse
.loop
->from
[0]);
4415 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4417 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4418 gfc_array_index_type
,
4419 rse
.loop
->loopvar
[0], offset
);
4421 /* Now use the offset for the reference. */
4422 tmp
= build_fold_indirect_ref_loc (input_location
,
4424 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4426 if (expr
->ts
.type
== BT_CHARACTER
)
4427 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4429 gfc_conv_expr (&lse
, expr
);
4431 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4433 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4434 gfc_add_expr_to_block (&body
, tmp
);
4436 /* Generate the copying loops. */
4437 gfc_trans_scalarizing_loops (&loop2
, &body
);
4439 /* Wrap the whole thing up by adding the second loop to the post-block
4440 and following it by the post-block of the first loop. In this way,
4441 if the temporary needs freeing, it is done after use! */
4442 if (intent
!= INTENT_IN
)
4444 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4445 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4450 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4452 gfc_cleanup_loop (&loop
);
4453 gfc_cleanup_loop (&loop2
);
4455 /* Pass the string length to the argument expression. */
4456 if (expr
->ts
.type
== BT_CHARACTER
)
4457 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4459 /* Determine the offset for pointer formal arguments and set the
4463 size
= gfc_index_one_node
;
4464 offset
= gfc_index_zero_node
;
4465 for (n
= 0; n
< dimen
; n
++)
4467 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4469 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4470 gfc_array_index_type
, tmp
,
4471 gfc_index_one_node
);
4472 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4476 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4479 gfc_index_one_node
);
4480 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4481 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4482 gfc_array_index_type
,
4484 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4485 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4486 gfc_array_index_type
,
4487 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4488 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4489 gfc_array_index_type
,
4490 tmp
, gfc_index_one_node
);
4491 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4492 gfc_array_index_type
, size
, tmp
);
4495 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4499 /* We want either the address for the data or the address of the descriptor,
4500 depending on the mode of passing array arguments. */
4502 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4504 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4510 /* Generate the code for argument list functions. */
4513 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4515 /* Pass by value for g77 %VAL(arg), pass the address
4516 indirectly for %LOC, else by reference. Thus %REF
4517 is a "do-nothing" and %LOC is the same as an F95
4519 if (strncmp (name
, "%VAL", 4) == 0)
4520 gfc_conv_expr (se
, expr
);
4521 else if (strncmp (name
, "%LOC", 4) == 0)
4523 gfc_conv_expr_reference (se
, expr
);
4524 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4526 else if (strncmp (name
, "%REF", 4) == 0)
4527 gfc_conv_expr_reference (se
, expr
);
4529 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4533 /* Generate code for a procedure call. Note can return se->post != NULL.
4534 If se->direct_byref is set then se->expr contains the return parameter.
4535 Return nonzero, if the call has alternate specifiers.
4536 'expr' is only needed for procedure pointer components. */
4539 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4540 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4541 vec
<tree
, va_gc
> *append_args
)
4543 gfc_interface_mapping mapping
;
4544 vec
<tree
, va_gc
> *arglist
;
4545 vec
<tree
, va_gc
> *retargs
;
4549 gfc_array_info
*info
;
4556 vec
<tree
, va_gc
> *stringargs
;
4557 vec
<tree
, va_gc
> *optionalargs
;
4559 gfc_formal_arglist
*formal
;
4560 gfc_actual_arglist
*arg
;
4561 int has_alternate_specifier
= 0;
4562 bool need_interface_mapping
;
4570 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4571 gfc_component
*comp
= NULL
;
4578 optionalargs
= NULL
;
4583 comp
= gfc_get_proc_ptr_comp (expr
);
4587 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4589 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4590 if (se
->ss
->info
->useflags
)
4592 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4593 && sym
->result
->attr
.dimension
)
4594 || (comp
&& comp
->attr
.dimension
)
4595 || gfc_is_alloc_class_array_function (expr
));
4596 gcc_assert (se
->loop
!= NULL
);
4597 /* Access the previously obtained result. */
4598 gfc_conv_tmp_array_ref (se
);
4602 info
= &se
->ss
->info
->data
.array
;
4607 gfc_init_block (&post
);
4608 gfc_init_interface_mapping (&mapping
);
4611 formal
= gfc_sym_get_dummy_args (sym
);
4612 need_interface_mapping
= sym
->attr
.dimension
||
4613 (sym
->ts
.type
== BT_CHARACTER
4614 && sym
->ts
.u
.cl
->length
4615 && sym
->ts
.u
.cl
->length
->expr_type
4620 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4621 need_interface_mapping
= comp
->attr
.dimension
||
4622 (comp
->ts
.type
== BT_CHARACTER
4623 && comp
->ts
.u
.cl
->length
4624 && comp
->ts
.u
.cl
->length
->expr_type
4628 base_object
= NULL_TREE
;
4629 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4630 is the third and fourth argument to such a function call a value
4631 denoting the number of elements to copy (i.e., most of the time the
4632 length of a deferred length string). */
4633 ulim_copy
= formal
== NULL
&& UNLIMITED_POLY (sym
)
4634 && strcmp ("_copy", comp
->name
) == 0;
4636 /* Evaluate the arguments. */
4637 for (arg
= args
, argc
= 0; arg
!= NULL
;
4638 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4641 fsym
= formal
? formal
->sym
: NULL
;
4642 parm_kind
= MISSING
;
4644 /* Class array expressions are sometimes coming completely unadorned
4645 with either arrayspec or _data component. Correct that here.
4646 OOP-TODO: Move this to the frontend. */
4647 if (e
&& e
->expr_type
== EXPR_VARIABLE
4649 && e
->ts
.type
== BT_CLASS
4650 && (CLASS_DATA (e
)->attr
.codimension
4651 || CLASS_DATA (e
)->attr
.dimension
))
4653 gfc_typespec temp_ts
= e
->ts
;
4654 gfc_add_class_array_ref (e
);
4660 if (se
->ignore_optional
)
4662 /* Some intrinsics have already been resolved to the correct
4666 else if (arg
->label
)
4668 has_alternate_specifier
= 1;
4673 gfc_init_se (&parmse
, NULL
);
4675 /* For scalar arguments with VALUE attribute which are passed by
4676 value, pass "0" and a hidden argument gives the optional
4678 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4679 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4680 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4682 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4684 vec_safe_push (optionalargs
, boolean_false_node
);
4688 /* Pass a NULL pointer for an absent arg. */
4689 parmse
.expr
= null_pointer_node
;
4690 if (arg
->missing_arg_type
== BT_CHARACTER
)
4691 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4696 else if (arg
->expr
->expr_type
== EXPR_NULL
4697 && fsym
&& !fsym
->attr
.pointer
4698 && (fsym
->ts
.type
!= BT_CLASS
4699 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4701 /* Pass a NULL pointer to denote an absent arg. */
4702 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4703 && (fsym
->ts
.type
!= BT_CLASS
4704 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4705 gfc_init_se (&parmse
, NULL
);
4706 parmse
.expr
= null_pointer_node
;
4707 if (arg
->missing_arg_type
== BT_CHARACTER
)
4708 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4710 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4711 && e
->ts
.type
== BT_DERIVED
)
4713 /* The derived type needs to be converted to a temporary
4715 gfc_init_se (&parmse
, se
);
4716 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4718 && e
->expr_type
== EXPR_VARIABLE
4719 && e
->symtree
->n
.sym
->attr
.optional
,
4720 CLASS_DATA (fsym
)->attr
.class_pointer
4721 || CLASS_DATA (fsym
)->attr
.allocatable
);
4723 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4725 /* The intrinsic type needs to be converted to a temporary
4726 CLASS object for the unlimited polymorphic formal. */
4727 gfc_init_se (&parmse
, se
);
4728 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4730 else if (se
->ss
&& se
->ss
->info
->useflags
)
4736 /* An elemental function inside a scalarized loop. */
4737 gfc_init_se (&parmse
, se
);
4738 parm_kind
= ELEMENTAL
;
4740 /* When no fsym is present, ulim_copy is set and this is a third or
4741 fourth argument, use call-by-value instead of by reference to
4742 hand the length properties to the copy routine (i.e., most of the
4743 time this will be a call to a __copy_character_* routine where the
4744 third and fourth arguments are the lengths of a deferred length
4746 if ((fsym
&& fsym
->attr
.value
)
4747 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4748 gfc_conv_expr (&parmse
, e
);
4750 gfc_conv_expr_reference (&parmse
, e
);
4752 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4753 && e
->expr_type
== EXPR_FUNCTION
)
4754 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4757 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4758 && gfc_is_class_container_ref (e
))
4760 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4762 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4763 && e
->symtree
->n
.sym
->attr
.optional
)
4765 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4766 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4767 TREE_TYPE (parmse
.expr
),
4769 fold_convert (TREE_TYPE (parmse
.expr
),
4770 null_pointer_node
));
4774 /* If we are passing an absent array as optional dummy to an
4775 elemental procedure, make sure that we pass NULL when the data
4776 pointer is NULL. We need this extra conditional because of
4777 scalarization which passes arrays elements to the procedure,
4778 ignoring the fact that the array can be absent/unallocated/... */
4779 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4781 tree descriptor_data
;
4783 descriptor_data
= ss
->info
->data
.array
.data
;
4784 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4786 fold_convert (TREE_TYPE (descriptor_data
),
4787 null_pointer_node
));
4789 = fold_build3_loc (input_location
, COND_EXPR
,
4790 TREE_TYPE (parmse
.expr
),
4791 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4792 fold_convert (TREE_TYPE (parmse
.expr
),
4797 /* The scalarizer does not repackage the reference to a class
4798 array - instead it returns a pointer to the data element. */
4799 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4800 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4801 fsym
->attr
.intent
!= INTENT_IN
4802 && (CLASS_DATA (fsym
)->attr
.class_pointer
4803 || CLASS_DATA (fsym
)->attr
.allocatable
),
4805 && e
->expr_type
== EXPR_VARIABLE
4806 && e
->symtree
->n
.sym
->attr
.optional
,
4807 CLASS_DATA (fsym
)->attr
.class_pointer
4808 || CLASS_DATA (fsym
)->attr
.allocatable
);
4815 gfc_init_se (&parmse
, NULL
);
4817 /* Check whether the expression is a scalar or not; we cannot use
4818 e->rank as it can be nonzero for functions arguments. */
4819 argss
= gfc_walk_expr (e
);
4820 scalar
= argss
== gfc_ss_terminator
;
4822 gfc_free_ss_chain (argss
);
4824 /* Special handling for passing scalar polymorphic coarrays;
4825 otherwise one passes "class->_data.data" instead of "&class". */
4826 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4827 && fsym
&& fsym
->ts
.type
== BT_CLASS
4828 && CLASS_DATA (fsym
)->attr
.codimension
4829 && !CLASS_DATA (fsym
)->attr
.dimension
)
4831 gfc_add_class_array_ref (e
);
4832 parmse
.want_coarray
= 1;
4836 /* A scalar or transformational function. */
4839 if (e
->expr_type
== EXPR_VARIABLE
4840 && e
->symtree
->n
.sym
->attr
.cray_pointee
4841 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4843 /* The Cray pointer needs to be converted to a pointer to
4844 a type given by the expression. */
4845 gfc_conv_expr (&parmse
, e
);
4846 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4847 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4848 parmse
.expr
= convert (type
, tmp
);
4850 else if (fsym
&& fsym
->attr
.value
)
4852 if (fsym
->ts
.type
== BT_CHARACTER
4853 && fsym
->ts
.is_c_interop
4854 && fsym
->ns
->proc_name
!= NULL
4855 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4858 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4859 if (parmse
.expr
== NULL
)
4860 gfc_conv_expr (&parmse
, e
);
4864 gfc_conv_expr (&parmse
, e
);
4865 if (fsym
->attr
.optional
4866 && fsym
->ts
.type
!= BT_CLASS
4867 && fsym
->ts
.type
!= BT_DERIVED
)
4869 if (e
->expr_type
!= EXPR_VARIABLE
4870 || !e
->symtree
->n
.sym
->attr
.optional
4872 vec_safe_push (optionalargs
, boolean_true_node
);
4875 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4876 if (!e
->symtree
->n
.sym
->attr
.value
)
4878 = fold_build3_loc (input_location
, COND_EXPR
,
4879 TREE_TYPE (parmse
.expr
),
4881 fold_convert (TREE_TYPE (parmse
.expr
),
4882 integer_zero_node
));
4884 vec_safe_push (optionalargs
, tmp
);
4889 else if (arg
->name
&& arg
->name
[0] == '%')
4890 /* Argument list functions %VAL, %LOC and %REF are signalled
4891 through arg->name. */
4892 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4893 else if ((e
->expr_type
== EXPR_FUNCTION
)
4894 && ((e
->value
.function
.esym
4895 && e
->value
.function
.esym
->result
->attr
.pointer
)
4896 || (!e
->value
.function
.esym
4897 && e
->symtree
->n
.sym
->attr
.pointer
))
4898 && fsym
&& fsym
->attr
.target
)
4900 gfc_conv_expr (&parmse
, e
);
4901 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4903 else if (e
->expr_type
== EXPR_FUNCTION
4904 && e
->symtree
->n
.sym
->result
4905 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4906 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4908 /* Functions returning procedure pointers. */
4909 gfc_conv_expr (&parmse
, e
);
4910 if (fsym
&& fsym
->attr
.proc_pointer
)
4911 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4915 if (e
->ts
.type
== BT_CLASS
&& fsym
4916 && fsym
->ts
.type
== BT_CLASS
4917 && (!CLASS_DATA (fsym
)->as
4918 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4919 && CLASS_DATA (e
)->attr
.codimension
)
4921 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4922 gcc_assert (!CLASS_DATA (fsym
)->as
);
4923 gfc_add_class_array_ref (e
);
4924 parmse
.want_coarray
= 1;
4925 gfc_conv_expr_reference (&parmse
, e
);
4926 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4928 && e
->expr_type
== EXPR_VARIABLE
);
4930 else if (e
->ts
.type
== BT_CLASS
&& fsym
4931 && fsym
->ts
.type
== BT_CLASS
4932 && !CLASS_DATA (fsym
)->as
4933 && !CLASS_DATA (e
)->as
4934 && strcmp (fsym
->ts
.u
.derived
->name
,
4935 e
->ts
.u
.derived
->name
))
4937 type
= gfc_typenode_for_spec (&fsym
->ts
);
4938 var
= gfc_create_var (type
, fsym
->name
);
4939 gfc_conv_expr (&parmse
, e
);
4940 if (fsym
->attr
.optional
4941 && e
->expr_type
== EXPR_VARIABLE
4942 && e
->symtree
->n
.sym
->attr
.optional
)
4946 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4947 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4948 boolean_type_node
, tmp
,
4949 fold_convert (TREE_TYPE (tmp
),
4950 null_pointer_node
));
4951 gfc_start_block (&block
);
4952 gfc_add_modify (&block
, var
,
4953 fold_build1_loc (input_location
,
4955 type
, parmse
.expr
));
4956 gfc_add_expr_to_block (&parmse
.pre
,
4957 fold_build3_loc (input_location
,
4958 COND_EXPR
, void_type_node
,
4959 cond
, gfc_finish_block (&block
),
4960 build_empty_stmt (input_location
)));
4961 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4962 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4963 TREE_TYPE (parmse
.expr
),
4965 fold_convert (TREE_TYPE (parmse
.expr
),
4966 null_pointer_node
));
4970 gfc_add_modify (&parmse
.pre
, var
,
4971 fold_build1_loc (input_location
,
4973 type
, parmse
.expr
));
4974 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4978 gfc_conv_expr_reference (&parmse
, e
);
4980 /* Catch base objects that are not variables. */
4981 if (e
->ts
.type
== BT_CLASS
4982 && e
->expr_type
!= EXPR_VARIABLE
4983 && expr
&& e
== expr
->base_expr
)
4984 base_object
= build_fold_indirect_ref_loc (input_location
,
4987 /* A class array element needs converting back to be a
4988 class object, if the formal argument is a class object. */
4989 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4990 && e
->ts
.type
== BT_CLASS
4991 && ((CLASS_DATA (fsym
)->as
4992 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4993 || CLASS_DATA (e
)->attr
.dimension
))
4994 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4995 fsym
->attr
.intent
!= INTENT_IN
4996 && (CLASS_DATA (fsym
)->attr
.class_pointer
4997 || CLASS_DATA (fsym
)->attr
.allocatable
),
4999 && e
->expr_type
== EXPR_VARIABLE
5000 && e
->symtree
->n
.sym
->attr
.optional
,
5001 CLASS_DATA (fsym
)->attr
.class_pointer
5002 || CLASS_DATA (fsym
)->attr
.allocatable
);
5004 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5005 allocated on entry, it must be deallocated. */
5006 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5007 && (fsym
->attr
.allocatable
5008 || (fsym
->ts
.type
== BT_CLASS
5009 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5014 gfc_init_block (&block
);
5016 if (e
->ts
.type
== BT_CLASS
)
5017 ptr
= gfc_class_data_get (ptr
);
5019 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5021 gfc_add_expr_to_block (&block
, tmp
);
5022 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5023 void_type_node
, ptr
,
5025 gfc_add_expr_to_block (&block
, tmp
);
5027 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5029 gfc_add_modify (&block
, ptr
,
5030 fold_convert (TREE_TYPE (ptr
),
5031 null_pointer_node
));
5032 gfc_add_expr_to_block (&block
, tmp
);
5034 else if (fsym
->ts
.type
== BT_CLASS
)
5037 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5038 tmp
= gfc_get_symbol_decl (vtab
);
5039 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5040 ptr
= gfc_class_vptr_get (parmse
.expr
);
5041 gfc_add_modify (&block
, ptr
,
5042 fold_convert (TREE_TYPE (ptr
), tmp
));
5043 gfc_add_expr_to_block (&block
, tmp
);
5046 if (fsym
->attr
.optional
5047 && e
->expr_type
== EXPR_VARIABLE
5048 && e
->symtree
->n
.sym
->attr
.optional
)
5050 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5052 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5053 gfc_finish_block (&block
),
5054 build_empty_stmt (input_location
));
5057 tmp
= gfc_finish_block (&block
);
5059 gfc_add_expr_to_block (&se
->pre
, tmp
);
5062 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5063 || fsym
->ts
.type
== BT_ASSUMED
)
5064 && e
->ts
.type
== BT_CLASS
5065 && !CLASS_DATA (e
)->attr
.dimension
5066 && !CLASS_DATA (e
)->attr
.codimension
)
5067 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5069 /* Wrap scalar variable in a descriptor. We need to convert
5070 the address of a pointer back to the pointer itself before,
5071 we can assign it to the data field. */
5073 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5074 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5077 if (TREE_CODE (tmp
) == ADDR_EXPR
5078 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5079 tmp
= TREE_OPERAND (tmp
, 0);
5080 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5082 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5085 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5086 && ((fsym
->attr
.pointer
5087 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5088 || (fsym
->attr
.proc_pointer
5089 && !(e
->expr_type
== EXPR_VARIABLE
5090 && e
->symtree
->n
.sym
->attr
.dummy
))
5091 || (fsym
->attr
.proc_pointer
5092 && e
->expr_type
== EXPR_VARIABLE
5093 && gfc_is_proc_ptr_comp (e
))
5094 || (fsym
->attr
.allocatable
5095 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5097 /* Scalar pointer dummy args require an extra level of
5098 indirection. The null pointer already contains
5099 this level of indirection. */
5100 parm_kind
= SCALAR_POINTER
;
5101 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5105 else if (e
->ts
.type
== BT_CLASS
5106 && fsym
&& fsym
->ts
.type
== BT_CLASS
5107 && (CLASS_DATA (fsym
)->attr
.dimension
5108 || CLASS_DATA (fsym
)->attr
.codimension
))
5110 /* Pass a class array. */
5111 parmse
.use_offset
= 1;
5112 gfc_conv_expr_descriptor (&parmse
, e
);
5114 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5115 allocated on entry, it must be deallocated. */
5116 if (fsym
->attr
.intent
== INTENT_OUT
5117 && CLASS_DATA (fsym
)->attr
.allocatable
)
5122 gfc_init_block (&block
);
5124 ptr
= gfc_class_data_get (ptr
);
5126 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5127 NULL_TREE
, NULL_TREE
,
5130 gfc_add_expr_to_block (&block
, tmp
);
5131 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5132 void_type_node
, ptr
,
5134 gfc_add_expr_to_block (&block
, tmp
);
5135 gfc_reset_vptr (&block
, e
);
5137 if (fsym
->attr
.optional
5138 && e
->expr_type
== EXPR_VARIABLE
5140 || (e
->ref
->type
== REF_ARRAY
5141 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5142 && e
->symtree
->n
.sym
->attr
.optional
)
5144 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5146 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5147 gfc_finish_block (&block
),
5148 build_empty_stmt (input_location
));
5151 tmp
= gfc_finish_block (&block
);
5153 gfc_add_expr_to_block (&se
->pre
, tmp
);
5156 /* The conversion does not repackage the reference to a class
5157 array - _data descriptor. */
5158 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5159 fsym
->attr
.intent
!= INTENT_IN
5160 && (CLASS_DATA (fsym
)->attr
.class_pointer
5161 || CLASS_DATA (fsym
)->attr
.allocatable
),
5163 && e
->expr_type
== EXPR_VARIABLE
5164 && e
->symtree
->n
.sym
->attr
.optional
,
5165 CLASS_DATA (fsym
)->attr
.class_pointer
5166 || CLASS_DATA (fsym
)->attr
.allocatable
);
5170 /* If the procedure requires an explicit interface, the actual
5171 argument is passed according to the corresponding formal
5172 argument. If the corresponding formal argument is a POINTER,
5173 ALLOCATABLE or assumed shape, we do not use g77's calling
5174 convention, and pass the address of the array descriptor
5175 instead. Otherwise we use g77's calling convention. */
5178 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5179 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
5180 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5182 f
= f
|| !comp
->attr
.always_explicit
;
5184 f
= f
|| !sym
->attr
.always_explicit
;
5186 /* If the argument is a function call that may not create
5187 a temporary for the result, we have to check that we
5188 can do it, i.e. that there is no alias between this
5189 argument and another one. */
5190 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5196 intent
= fsym
->attr
.intent
;
5198 intent
= INTENT_UNKNOWN
;
5200 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5202 parmse
.force_tmp
= 1;
5204 iarg
= e
->value
.function
.actual
->expr
;
5206 /* Temporary needed if aliasing due to host association. */
5207 if (sym
->attr
.contained
5209 && !sym
->attr
.implicit_pure
5210 && !sym
->attr
.use_assoc
5211 && iarg
->expr_type
== EXPR_VARIABLE
5212 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5213 parmse
.force_tmp
= 1;
5215 /* Ditto within module. */
5216 if (sym
->attr
.use_assoc
5218 && !sym
->attr
.implicit_pure
5219 && iarg
->expr_type
== EXPR_VARIABLE
5220 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5221 parmse
.force_tmp
= 1;
5224 if (e
->expr_type
== EXPR_VARIABLE
5225 && is_subref_array (e
))
5226 /* The actual argument is a component reference to an
5227 array of derived types. In this case, the argument
5228 is converted to a temporary, which is passed and then
5229 written back after the procedure call. */
5230 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5231 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5232 fsym
&& fsym
->attr
.pointer
);
5233 else if (gfc_is_class_array_ref (e
, NULL
)
5234 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5235 /* The actual argument is a component reference to an
5236 array of derived types. In this case, the argument
5237 is converted to a temporary, which is passed and then
5238 written back after the procedure call.
5239 OOP-TODO: Insert code so that if the dynamic type is
5240 the same as the declared type, copy-in/copy-out does
5242 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5243 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5244 fsym
&& fsym
->attr
.pointer
);
5246 else if (gfc_is_alloc_class_array_function (e
)
5247 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5248 /* See previous comment. For function actual argument,
5249 the write out is not needed so the intent is set as
5252 e
->must_finalize
= 1;
5253 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5255 fsym
&& fsym
->attr
.pointer
);
5258 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
5260 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5261 allocated on entry, it must be deallocated. */
5262 if (fsym
&& fsym
->attr
.allocatable
5263 && fsym
->attr
.intent
== INTENT_OUT
)
5265 tmp
= build_fold_indirect_ref_loc (input_location
,
5267 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5268 if (fsym
->attr
.optional
5269 && e
->expr_type
== EXPR_VARIABLE
5270 && e
->symtree
->n
.sym
->attr
.optional
)
5271 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5273 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5274 tmp
, build_empty_stmt (input_location
));
5275 gfc_add_expr_to_block (&se
->pre
, tmp
);
5280 /* The case with fsym->attr.optional is that of a user subroutine
5281 with an interface indicating an optional argument. When we call
5282 an intrinsic subroutine, however, fsym is NULL, but we might still
5283 have an optional argument, so we proceed to the substitution
5285 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5287 /* If an optional argument is itself an optional dummy argument,
5288 check its presence and substitute a null if absent. This is
5289 only needed when passing an array to an elemental procedure
5290 as then array elements are accessed - or no NULL pointer is
5291 allowed and a "1" or "0" should be passed if not present.
5292 When passing a non-array-descriptor full array to a
5293 non-array-descriptor dummy, no check is needed. For
5294 array-descriptor actual to array-descriptor dummy, see
5295 PR 41911 for why a check has to be inserted.
5296 fsym == NULL is checked as intrinsics required the descriptor
5297 but do not always set fsym. */
5298 if (e
->expr_type
== EXPR_VARIABLE
5299 && e
->symtree
->n
.sym
->attr
.optional
5300 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
5301 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5305 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5306 || fsym
->as
->type
== AS_ASSUMED_RANK
5307 || fsym
->as
->type
== AS_DEFERRED
))))))
5308 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5309 e
->representation
.length
);
5314 /* Obtain the character length of an assumed character length
5315 length procedure from the typespec. */
5316 if (fsym
->ts
.type
== BT_CHARACTER
5317 && parmse
.string_length
== NULL_TREE
5318 && e
->ts
.type
== BT_PROCEDURE
5319 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5320 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5321 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5323 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5324 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5328 if (fsym
&& need_interface_mapping
&& e
)
5329 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5331 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5332 gfc_add_block_to_block (&post
, &parmse
.post
);
5334 /* Allocated allocatable components of derived types must be
5335 deallocated for non-variable scalars. Non-variable arrays are
5336 dealt with in trans-array.c(gfc_conv_array_parameter). */
5337 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5338 && e
->ts
.u
.derived
->attr
.alloc_comp
5339 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
5340 && e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)
5343 tmp
= build_fold_indirect_ref_loc (input_location
,
5345 parm_rank
= e
->rank
;
5353 case (SCALAR_POINTER
):
5354 tmp
= build_fold_indirect_ref_loc (input_location
,
5359 if (e
->expr_type
== EXPR_OP
5360 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5361 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5364 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5365 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5366 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5369 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5371 /* The derived type is passed to gfc_deallocate_alloc_comp.
5372 Therefore, class actuals can handled correctly but derived
5373 types passed to class formals need the _data component. */
5374 tmp
= gfc_class_data_get (tmp
);
5375 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5376 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5379 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5381 gfc_add_expr_to_block (&se
->post
, tmp
);
5384 /* Add argument checking of passing an unallocated/NULL actual to
5385 a nonallocatable/nonpointer dummy. */
5387 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5389 symbol_attribute attr
;
5393 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5394 attr
= gfc_expr_attr (e
);
5396 goto end_pointer_check
;
5398 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5399 allocatable to an optional dummy, cf. 12.5.2.12. */
5400 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5401 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5402 goto end_pointer_check
;
5406 /* If the actual argument is an optional pointer/allocatable and
5407 the formal argument takes an nonpointer optional value,
5408 it is invalid to pass a non-present argument on, even
5409 though there is no technical reason for this in gfortran.
5410 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5411 tree present
, null_ptr
, type
;
5413 if (attr
.allocatable
5414 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5415 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5416 "allocated or not present",
5417 e
->symtree
->n
.sym
->name
);
5418 else if (attr
.pointer
5419 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5420 msg
= xasprintf ("Pointer actual argument '%s' is not "
5421 "associated or not present",
5422 e
->symtree
->n
.sym
->name
);
5423 else if (attr
.proc_pointer
5424 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5425 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5426 "associated or not present",
5427 e
->symtree
->n
.sym
->name
);
5429 goto end_pointer_check
;
5431 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5432 type
= TREE_TYPE (present
);
5433 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5434 boolean_type_node
, present
,
5436 null_pointer_node
));
5437 type
= TREE_TYPE (parmse
.expr
);
5438 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5439 boolean_type_node
, parmse
.expr
,
5441 null_pointer_node
));
5442 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5443 boolean_type_node
, present
, null_ptr
);
5447 if (attr
.allocatable
5448 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5449 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5450 "allocated", e
->symtree
->n
.sym
->name
);
5451 else if (attr
.pointer
5452 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5453 msg
= xasprintf ("Pointer actual argument '%s' is not "
5454 "associated", e
->symtree
->n
.sym
->name
);
5455 else if (attr
.proc_pointer
5456 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5457 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5458 "associated", e
->symtree
->n
.sym
->name
);
5460 goto end_pointer_check
;
5464 /* If the argument is passed by value, we need to strip the
5466 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5467 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5469 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5470 boolean_type_node
, tmp
,
5471 fold_convert (TREE_TYPE (tmp
),
5472 null_pointer_node
));
5475 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5481 /* Deferred length dummies pass the character length by reference
5482 so that the value can be returned. */
5483 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5485 if (INDIRECT_REF_P (parmse
.string_length
))
5486 /* In chains of functions/procedure calls the string_length already
5487 is a pointer to the variable holding the length. Therefore
5488 remove the deref on call. */
5489 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5492 tmp
= parmse
.string_length
;
5493 if (TREE_CODE (tmp
) != VAR_DECL
)
5494 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5495 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5499 /* Character strings are passed as two parameters, a length and a
5500 pointer - except for Bind(c) which only passes the pointer.
5501 An unlimited polymorphic formal argument likewise does not
5503 if (parmse
.string_length
!= NULL_TREE
5504 && !sym
->attr
.is_bind_c
5505 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5506 vec_safe_push (stringargs
, parmse
.string_length
);
5508 /* When calling __copy for character expressions to unlimited
5509 polymorphic entities, the dst argument needs a string length. */
5510 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5511 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5512 && arg
->next
&& arg
->next
->expr
5513 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5514 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5515 vec_safe_push (stringargs
, parmse
.string_length
);
5517 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5518 pass the token and the offset as additional arguments. */
5519 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5520 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5521 && !fsym
->attr
.allocatable
)
5522 || (fsym
->ts
.type
== BT_CLASS
5523 && CLASS_DATA (fsym
)->attr
.codimension
5524 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5526 /* Token and offset. */
5527 vec_safe_push (stringargs
, null_pointer_node
);
5528 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5529 gcc_assert (fsym
->attr
.optional
);
5531 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5532 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5533 && !fsym
->attr
.allocatable
)
5534 || (fsym
->ts
.type
== BT_CLASS
5535 && CLASS_DATA (fsym
)->attr
.codimension
5536 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5538 tree caf_decl
, caf_type
;
5541 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5542 caf_type
= TREE_TYPE (caf_decl
);
5544 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5545 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5546 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5547 tmp
= gfc_conv_descriptor_token (caf_decl
);
5548 else if (DECL_LANG_SPECIFIC (caf_decl
)
5549 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5550 tmp
= GFC_DECL_TOKEN (caf_decl
);
5553 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5554 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5555 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5558 vec_safe_push (stringargs
, tmp
);
5560 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5561 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5562 offset
= build_int_cst (gfc_array_index_type
, 0);
5563 else if (DECL_LANG_SPECIFIC (caf_decl
)
5564 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5565 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5566 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5567 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5569 offset
= build_int_cst (gfc_array_index_type
, 0);
5571 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5572 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5575 gcc_assert (POINTER_TYPE_P (caf_type
));
5579 tmp2
= fsym
->ts
.type
== BT_CLASS
5580 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5581 if ((fsym
->ts
.type
!= BT_CLASS
5582 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5583 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5584 || (fsym
->ts
.type
== BT_CLASS
5585 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5586 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5588 if (fsym
->ts
.type
== BT_CLASS
)
5589 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5592 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5593 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5595 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5596 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5598 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5599 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5602 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5605 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5606 gfc_array_index_type
,
5607 fold_convert (gfc_array_index_type
, tmp2
),
5608 fold_convert (gfc_array_index_type
, tmp
));
5609 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5610 gfc_array_index_type
, offset
, tmp
);
5612 vec_safe_push (stringargs
, offset
);
5615 vec_safe_push (arglist
, parmse
.expr
);
5617 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5624 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5625 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5626 else if (ts
.type
== BT_CHARACTER
)
5628 if (ts
.u
.cl
->length
== NULL
)
5630 /* Assumed character length results are not allowed by 5.1.1.5 of the
5631 standard and are trapped in resolve.c; except in the case of SPREAD
5632 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5633 we take the character length of the first argument for the result.
5634 For dummies, we have to look through the formal argument list for
5635 this function and use the character length found there.*/
5637 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5638 else if (!sym
->attr
.dummy
)
5639 cl
.backend_decl
= (*stringargs
)[0];
5642 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5643 for (; formal
; formal
= formal
->next
)
5644 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5645 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5647 len
= cl
.backend_decl
;
5653 /* Calculate the length of the returned string. */
5654 gfc_init_se (&parmse
, NULL
);
5655 if (need_interface_mapping
)
5656 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5658 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5659 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5660 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5662 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5663 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5664 gfc_charlen_type_node
, tmp
,
5665 build_int_cst (gfc_charlen_type_node
, 0));
5666 cl
.backend_decl
= tmp
;
5669 /* Set up a charlen structure for it. */
5674 len
= cl
.backend_decl
;
5677 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5678 || (!comp
&& gfc_return_by_reference (sym
));
5681 if (se
->direct_byref
)
5683 /* Sometimes, too much indirection can be applied; e.g. for
5684 function_result = array_valued_recursive_function. */
5685 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5686 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5687 && GFC_DESCRIPTOR_TYPE_P
5688 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5689 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5692 /* If the lhs of an assignment x = f(..) is allocatable and
5693 f2003 is allowed, we must do the automatic reallocation.
5694 TODO - deal with intrinsics, without using a temporary. */
5695 if (flag_realloc_lhs
5696 && se
->ss
&& se
->ss
->loop_chain
5697 && se
->ss
->loop_chain
->is_alloc_lhs
5698 && !expr
->value
.function
.isym
5699 && sym
->result
->as
!= NULL
)
5701 /* Evaluate the bounds of the result, if known. */
5702 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5705 /* Perform the automatic reallocation. */
5706 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5708 gfc_add_expr_to_block (&se
->pre
, tmp
);
5710 /* Pass the temporary as the first argument. */
5711 result
= info
->descriptor
;
5714 result
= build_fold_indirect_ref_loc (input_location
,
5716 vec_safe_push (retargs
, se
->expr
);
5718 else if (comp
&& comp
->attr
.dimension
)
5720 gcc_assert (se
->loop
&& info
);
5722 /* Set the type of the array. */
5723 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5724 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5726 /* Evaluate the bounds of the result, if known. */
5727 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5729 /* If the lhs of an assignment x = f(..) is allocatable and
5730 f2003 is allowed, we must not generate the function call
5731 here but should just send back the results of the mapping.
5732 This is signalled by the function ss being flagged. */
5733 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5735 gfc_free_interface_mapping (&mapping
);
5736 return has_alternate_specifier
;
5739 /* Create a temporary to store the result. In case the function
5740 returns a pointer, the temporary will be a shallow copy and
5741 mustn't be deallocated. */
5742 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5743 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5744 tmp
, NULL_TREE
, false,
5745 !comp
->attr
.pointer
, callee_alloc
,
5746 &se
->ss
->info
->expr
->where
);
5748 /* Pass the temporary as the first argument. */
5749 result
= info
->descriptor
;
5750 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5751 vec_safe_push (retargs
, tmp
);
5753 else if (!comp
&& sym
->result
->attr
.dimension
)
5755 gcc_assert (se
->loop
&& info
);
5757 /* Set the type of the array. */
5758 tmp
= gfc_typenode_for_spec (&ts
);
5759 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5761 /* Evaluate the bounds of the result, if known. */
5762 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5764 /* If the lhs of an assignment x = f(..) is allocatable and
5765 f2003 is allowed, we must not generate the function call
5766 here but should just send back the results of the mapping.
5767 This is signalled by the function ss being flagged. */
5768 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5770 gfc_free_interface_mapping (&mapping
);
5771 return has_alternate_specifier
;
5774 /* Create a temporary to store the result. In case the function
5775 returns a pointer, the temporary will be a shallow copy and
5776 mustn't be deallocated. */
5777 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5778 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5779 tmp
, NULL_TREE
, false,
5780 !sym
->attr
.pointer
, callee_alloc
,
5781 &se
->ss
->info
->expr
->where
);
5783 /* Pass the temporary as the first argument. */
5784 result
= info
->descriptor
;
5785 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5786 vec_safe_push (retargs
, tmp
);
5788 else if (ts
.type
== BT_CHARACTER
)
5790 /* Pass the string length. */
5791 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5792 type
= build_pointer_type (type
);
5794 /* Return an address to a char[0:len-1]* temporary for
5795 character pointers. */
5796 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5797 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5799 var
= gfc_create_var (type
, "pstr");
5801 if ((!comp
&& sym
->attr
.allocatable
)
5802 || (comp
&& comp
->attr
.allocatable
))
5804 gfc_add_modify (&se
->pre
, var
,
5805 fold_convert (TREE_TYPE (var
),
5806 null_pointer_node
));
5807 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5808 gfc_add_expr_to_block (&se
->post
, tmp
);
5811 /* Provide an address expression for the function arguments. */
5812 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5815 var
= gfc_conv_string_tmp (se
, type
, len
);
5817 vec_safe_push (retargs
, var
);
5821 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5823 type
= gfc_get_complex_type (ts
.kind
);
5824 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5825 vec_safe_push (retargs
, var
);
5828 /* Add the string length to the argument list. */
5829 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5832 if (TREE_CODE (tmp
) != VAR_DECL
)
5833 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5834 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5835 vec_safe_push (retargs
, tmp
);
5837 else if (ts
.type
== BT_CHARACTER
)
5838 vec_safe_push (retargs
, len
);
5840 gfc_free_interface_mapping (&mapping
);
5842 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5843 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5844 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5845 vec_safe_reserve (retargs
, arglen
);
5847 /* Add the return arguments. */
5848 retargs
->splice (arglist
);
5850 /* Add the hidden present status for optional+value to the arguments. */
5851 retargs
->splice (optionalargs
);
5853 /* Add the hidden string length parameters to the arguments. */
5854 retargs
->splice (stringargs
);
5856 /* We may want to append extra arguments here. This is used e.g. for
5857 calls to libgfortran_matmul_??, which need extra information. */
5858 if (!vec_safe_is_empty (append_args
))
5859 retargs
->splice (append_args
);
5862 /* Generate the actual call. */
5863 if (base_object
== NULL_TREE
)
5864 conv_function_val (se
, sym
, expr
);
5866 conv_base_obj_fcn_val (se
, base_object
, expr
);
5868 /* If there are alternate return labels, function type should be
5869 integer. Can't modify the type in place though, since it can be shared
5870 with other functions. For dummy arguments, the typing is done to
5871 this result, even if it has to be repeated for each call. */
5872 if (has_alternate_specifier
5873 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5875 if (!sym
->attr
.dummy
)
5877 TREE_TYPE (sym
->backend_decl
)
5878 = build_function_type (integer_type_node
,
5879 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5880 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5883 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5886 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5887 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5889 /* Allocatable scalar function results must be freed and nullified
5890 after use. This necessitates the creation of a temporary to
5891 hold the result to prevent duplicate calls. */
5892 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
5893 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
5895 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5896 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
5898 tmp
= gfc_call_free (tmp
);
5899 gfc_add_expr_to_block (&post
, tmp
);
5900 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
5903 /* If we have a pointer function, but we don't want a pointer, e.g.
5906 where f is pointer valued, we have to dereference the result. */
5907 if (!se
->want_pointer
&& !byref
5908 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5909 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5910 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5912 /* f2c calling conventions require a scalar default real function to
5913 return a double precision result. Convert this back to default
5914 real. We only care about the cases that can happen in Fortran 77.
5916 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5917 && sym
->ts
.kind
== gfc_default_real_kind
5918 && !sym
->attr
.always_explicit
)
5919 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5921 /* A pure function may still have side-effects - it may modify its
5923 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5925 if (!sym
->attr
.pure
)
5926 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5931 /* Add the function call to the pre chain. There is no expression. */
5932 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5933 se
->expr
= NULL_TREE
;
5935 if (!se
->direct_byref
)
5937 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5939 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5941 /* Check the data pointer hasn't been modified. This would
5942 happen in a function returning a pointer. */
5943 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5944 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5947 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5950 se
->expr
= info
->descriptor
;
5951 /* Bundle in the string length. */
5952 se
->string_length
= len
;
5954 else if (ts
.type
== BT_CHARACTER
)
5956 /* Dereference for character pointer results. */
5957 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5958 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5959 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5963 se
->string_length
= len
;
5967 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5968 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5973 /* Follow the function call with the argument post block. */
5976 gfc_add_block_to_block (&se
->pre
, &post
);
5978 /* Transformational functions of derived types with allocatable
5979 components must have the result allocatable components copied. */
5980 arg
= expr
->value
.function
.actual
;
5981 if (result
&& arg
&& expr
->rank
5982 && expr
->value
.function
.isym
5983 && expr
->value
.function
.isym
->transformational
5984 && arg
->expr
->ts
.type
== BT_DERIVED
5985 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5988 /* Copy the allocatable components. We have to use a
5989 temporary here to prevent source allocatable components
5990 from being corrupted. */
5991 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5992 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5993 result
, tmp2
, expr
->rank
);
5994 gfc_add_expr_to_block (&se
->pre
, tmp
);
5995 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5997 gfc_add_expr_to_block (&se
->pre
, tmp
);
5999 /* Finally free the temporary's data field. */
6000 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6001 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6002 NULL_TREE
, NULL_TREE
, true,
6004 gfc_add_expr_to_block (&se
->pre
, tmp
);
6009 /* For a function with a class array result, save the result as
6010 a temporary, set the info fields needed by the scalarizer and
6011 call the finalization function of the temporary. Note that the
6012 nullification of allocatable components needed by the result
6013 is done in gfc_trans_assignment_1. */
6014 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6015 && se
->ss
&& se
->ss
->loop
)
6016 || gfc_is_alloc_class_scalar_function (expr
))
6017 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6018 && expr
->must_finalize
)
6023 if (se
->ss
&& se
->ss
->loop
)
6025 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6026 tmp
= gfc_class_data_get (se
->expr
);
6027 info
->descriptor
= tmp
;
6028 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6029 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6030 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6032 tree dim
= gfc_rank_cst
[n
];
6033 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6034 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6039 /* TODO Eliminate the doubling of temporaries. This
6040 one is necessary to ensure no memory leakage. */
6041 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6042 tmp
= gfc_class_data_get (se
->expr
);
6043 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6044 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6047 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6048 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6051 fold_convert (TREE_TYPE (final_fndecl
),
6052 null_pointer_node
));
6053 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6055 tmp
= build_call_expr_loc (input_location
,
6057 gfc_build_addr_expr (NULL
, tmp
),
6058 gfc_class_vtab_size_get (se
->expr
),
6059 boolean_false_node
);
6060 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6061 void_type_node
, is_final
, tmp
,
6062 build_empty_stmt (input_location
));
6064 if (se
->ss
&& se
->ss
->loop
)
6066 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6067 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
6068 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6072 gfc_add_expr_to_block (&se
->post
, tmp
);
6073 tmp
= gfc_class_data_get (se
->expr
);
6074 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
6075 gfc_add_expr_to_block (&se
->post
, tmp
);
6077 expr
->must_finalize
= 0;
6080 gfc_add_block_to_block (&se
->post
, &post
);
6083 return has_alternate_specifier
;
6087 /* Fill a character string with spaces. */
6090 fill_with_spaces (tree start
, tree type
, tree size
)
6092 stmtblock_t block
, loop
;
6093 tree i
, el
, exit_label
, cond
, tmp
;
6095 /* For a simple char type, we can call memset(). */
6096 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6097 return build_call_expr_loc (input_location
,
6098 builtin_decl_explicit (BUILT_IN_MEMSET
),
6100 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6101 lang_hooks
.to_target_charset (' ')),
6104 /* Otherwise, we use a loop:
6105 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6109 /* Initialize variables. */
6110 gfc_init_block (&block
);
6111 i
= gfc_create_var (sizetype
, "i");
6112 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6113 el
= gfc_create_var (build_pointer_type (type
), "el");
6114 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6115 exit_label
= gfc_build_label_decl (NULL_TREE
);
6116 TREE_USED (exit_label
) = 1;
6120 gfc_init_block (&loop
);
6122 /* Exit condition. */
6123 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6124 build_zero_cst (sizetype
));
6125 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6126 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6127 build_empty_stmt (input_location
));
6128 gfc_add_expr_to_block (&loop
, tmp
);
6131 gfc_add_modify (&loop
,
6132 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6133 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6135 /* Increment loop variables. */
6136 gfc_add_modify (&loop
, i
,
6137 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6138 TYPE_SIZE_UNIT (type
)));
6139 gfc_add_modify (&loop
, el
,
6140 fold_build_pointer_plus_loc (input_location
,
6141 el
, TYPE_SIZE_UNIT (type
)));
6143 /* Making the loop... actually loop! */
6144 tmp
= gfc_finish_block (&loop
);
6145 tmp
= build1_v (LOOP_EXPR
, tmp
);
6146 gfc_add_expr_to_block (&block
, tmp
);
6148 /* The exit label. */
6149 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6150 gfc_add_expr_to_block (&block
, tmp
);
6153 return gfc_finish_block (&block
);
6157 /* Generate code to copy a string. */
6160 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6161 int dkind
, tree slength
, tree src
, int skind
)
6163 tree tmp
, dlen
, slen
;
6172 stmtblock_t tempblock
;
6174 gcc_assert (dkind
== skind
);
6176 if (slength
!= NULL_TREE
)
6178 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6179 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6183 slen
= build_int_cst (size_type_node
, 1);
6187 if (dlength
!= NULL_TREE
)
6189 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6190 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6194 dlen
= build_int_cst (size_type_node
, 1);
6198 /* Assign directly if the types are compatible. */
6199 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6200 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6202 gfc_add_modify (block
, dsc
, ssc
);
6206 /* Do nothing if the destination length is zero. */
6207 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6208 build_int_cst (size_type_node
, 0));
6210 /* The following code was previously in _gfortran_copy_string:
6212 // The two strings may overlap so we use memmove.
6214 copy_string (GFC_INTEGER_4 destlen, char * dest,
6215 GFC_INTEGER_4 srclen, const char * src)
6217 if (srclen >= destlen)
6219 // This will truncate if too long.
6220 memmove (dest, src, destlen);
6224 memmove (dest, src, srclen);
6226 memset (&dest[srclen], ' ', destlen - srclen);
6230 We're now doing it here for better optimization, but the logic
6233 /* For non-default character kinds, we have to multiply the string
6234 length by the base type size. */
6235 chartype
= gfc_get_char_type (dkind
);
6236 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6237 fold_convert (size_type_node
, slen
),
6238 fold_convert (size_type_node
,
6239 TYPE_SIZE_UNIT (chartype
)));
6240 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6241 fold_convert (size_type_node
, dlen
),
6242 fold_convert (size_type_node
,
6243 TYPE_SIZE_UNIT (chartype
)));
6245 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6246 dest
= fold_convert (pvoid_type_node
, dest
);
6248 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6250 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6251 src
= fold_convert (pvoid_type_node
, src
);
6253 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6255 /* Truncate string if source is too long. */
6256 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6258 tmp2
= build_call_expr_loc (input_location
,
6259 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6260 3, dest
, src
, dlen
);
6262 /* Else copy and pad with spaces. */
6263 tmp3
= build_call_expr_loc (input_location
,
6264 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6265 3, dest
, src
, slen
);
6267 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6268 tmp4
= fill_with_spaces (tmp4
, chartype
,
6269 fold_build2_loc (input_location
, MINUS_EXPR
,
6270 TREE_TYPE(dlen
), dlen
, slen
));
6272 gfc_init_block (&tempblock
);
6273 gfc_add_expr_to_block (&tempblock
, tmp3
);
6274 gfc_add_expr_to_block (&tempblock
, tmp4
);
6275 tmp3
= gfc_finish_block (&tempblock
);
6277 /* The whole copy_string function is there. */
6278 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6280 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6281 build_empty_stmt (input_location
));
6282 gfc_add_expr_to_block (block
, tmp
);
6286 /* Translate a statement function.
6287 The value of a statement function reference is obtained by evaluating the
6288 expression using the values of the actual arguments for the values of the
6289 corresponding dummy arguments. */
6292 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6296 gfc_formal_arglist
*fargs
;
6297 gfc_actual_arglist
*args
;
6300 gfc_saved_var
*saved_vars
;
6306 sym
= expr
->symtree
->n
.sym
;
6307 args
= expr
->value
.function
.actual
;
6308 gfc_init_se (&lse
, NULL
);
6309 gfc_init_se (&rse
, NULL
);
6312 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6314 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6315 temp_vars
= XCNEWVEC (tree
, n
);
6317 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6318 fargs
= fargs
->next
, n
++)
6320 /* Each dummy shall be specified, explicitly or implicitly, to be
6322 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6325 if (fsym
->ts
.type
== BT_CHARACTER
)
6327 /* Copy string arguments. */
6330 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6331 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6333 /* Create a temporary to hold the value. */
6334 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6335 fsym
->ts
.u
.cl
->backend_decl
6336 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6338 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6339 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6341 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6343 gfc_conv_expr (&rse
, args
->expr
);
6344 gfc_conv_string_parameter (&rse
);
6345 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6346 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6348 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6349 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6350 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6351 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6355 /* For everything else, just evaluate the expression. */
6357 /* Create a temporary to hold the value. */
6358 type
= gfc_typenode_for_spec (&fsym
->ts
);
6359 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6361 gfc_conv_expr (&lse
, args
->expr
);
6363 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6364 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6365 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6371 /* Use the temporary variables in place of the real ones. */
6372 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6373 fargs
= fargs
->next
, n
++)
6374 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6376 gfc_conv_expr (se
, sym
->value
);
6378 if (sym
->ts
.type
== BT_CHARACTER
)
6380 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6382 /* Force the expression to the correct length. */
6383 if (!INTEGER_CST_P (se
->string_length
)
6384 || tree_int_cst_lt (se
->string_length
,
6385 sym
->ts
.u
.cl
->backend_decl
))
6387 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6388 tmp
= gfc_create_var (type
, sym
->name
);
6389 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6390 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6391 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6395 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6398 /* Restore the original variables. */
6399 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6400 fargs
= fargs
->next
, n
++)
6401 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6407 /* Translate a function expression. */
6410 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6414 if (expr
->value
.function
.isym
)
6416 gfc_conv_intrinsic_function (se
, expr
);
6420 /* expr.value.function.esym is the resolved (specific) function symbol for
6421 most functions. However this isn't set for dummy procedures. */
6422 sym
= expr
->value
.function
.esym
;
6424 sym
= expr
->symtree
->n
.sym
;
6426 /* The IEEE_ARITHMETIC functions are caught here. */
6427 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6428 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6431 /* We distinguish statement functions from general functions to improve
6432 runtime performance. */
6433 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6435 gfc_conv_statement_function (se
, expr
);
6439 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6444 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6447 is_zero_initializer_p (gfc_expr
* expr
)
6449 if (expr
->expr_type
!= EXPR_CONSTANT
)
6452 /* We ignore constants with prescribed memory representations for now. */
6453 if (expr
->representation
.string
)
6456 switch (expr
->ts
.type
)
6459 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6462 return mpfr_zero_p (expr
->value
.real
)
6463 && MPFR_SIGN (expr
->value
.real
) >= 0;
6466 return expr
->value
.logical
== 0;
6469 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6470 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6471 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6472 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6482 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6487 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6488 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6490 gfc_conv_tmp_array_ref (se
);
6494 /* Build a static initializer. EXPR is the expression for the initial value.
6495 The other parameters describe the variable of the component being
6496 initialized. EXPR may be null. */
6499 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6500 bool array
, bool pointer
, bool procptr
)
6504 if (!(expr
|| pointer
|| procptr
))
6507 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6508 (these are the only two iso_c_binding derived types that can be
6509 used as initialization expressions). If so, we need to modify
6510 the 'expr' to be that for a (void *). */
6511 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6512 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6514 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6516 /* The derived symbol has already been converted to a (void *). Use
6518 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6519 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6521 gfc_init_se (&se
, NULL
);
6522 gfc_conv_constant (&se
, expr
);
6523 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6527 if (array
&& !procptr
)
6530 /* Arrays need special handling. */
6532 ctor
= gfc_build_null_descriptor (type
);
6533 /* Special case assigning an array to zero. */
6534 else if (is_zero_initializer_p (expr
))
6535 ctor
= build_constructor (type
, NULL
);
6537 ctor
= gfc_conv_array_initializer (type
, expr
);
6538 TREE_STATIC (ctor
) = 1;
6541 else if (pointer
|| procptr
)
6543 if (ts
->type
== BT_CLASS
&& !procptr
)
6545 gfc_init_se (&se
, NULL
);
6546 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6547 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6548 TREE_STATIC (se
.expr
) = 1;
6551 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6552 return fold_convert (type
, null_pointer_node
);
6555 gfc_init_se (&se
, NULL
);
6556 se
.want_pointer
= 1;
6557 gfc_conv_expr (&se
, expr
);
6558 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6568 gfc_init_se (&se
, NULL
);
6569 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6570 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6572 gfc_conv_structure (&se
, expr
, 1);
6573 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6574 TREE_STATIC (se
.expr
) = 1;
6579 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6580 TREE_STATIC (ctor
) = 1;
6585 gfc_init_se (&se
, NULL
);
6586 gfc_conv_constant (&se
, expr
);
6587 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6594 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6600 gfc_array_info
*lss_array
;
6607 gfc_start_block (&block
);
6609 /* Initialize the scalarizer. */
6610 gfc_init_loopinfo (&loop
);
6612 gfc_init_se (&lse
, NULL
);
6613 gfc_init_se (&rse
, NULL
);
6616 rss
= gfc_walk_expr (expr
);
6617 if (rss
== gfc_ss_terminator
)
6618 /* The rhs is scalar. Add a ss for the expression. */
6619 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6621 /* Create a SS for the destination. */
6622 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6624 lss_array
= &lss
->info
->data
.array
;
6625 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6626 lss_array
->descriptor
= dest
;
6627 lss_array
->data
= gfc_conv_array_data (dest
);
6628 lss_array
->offset
= gfc_conv_array_offset (dest
);
6629 for (n
= 0; n
< cm
->as
->rank
; n
++)
6631 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6632 lss_array
->stride
[n
] = gfc_index_one_node
;
6634 mpz_init (lss_array
->shape
[n
]);
6635 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6636 cm
->as
->lower
[n
]->value
.integer
);
6637 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6640 /* Associate the SS with the loop. */
6641 gfc_add_ss_to_loop (&loop
, lss
);
6642 gfc_add_ss_to_loop (&loop
, rss
);
6644 /* Calculate the bounds of the scalarization. */
6645 gfc_conv_ss_startstride (&loop
);
6647 /* Setup the scalarizing loops. */
6648 gfc_conv_loop_setup (&loop
, &expr
->where
);
6650 /* Setup the gfc_se structures. */
6651 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6652 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6655 gfc_mark_ss_chain_used (rss
, 1);
6657 gfc_mark_ss_chain_used (lss
, 1);
6659 /* Start the scalarized loop body. */
6660 gfc_start_scalarized_body (&loop
, &body
);
6662 gfc_conv_tmp_array_ref (&lse
);
6663 if (cm
->ts
.type
== BT_CHARACTER
)
6664 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6666 gfc_conv_expr (&rse
, expr
);
6668 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6669 gfc_add_expr_to_block (&body
, tmp
);
6671 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6673 /* Generate the copying loops. */
6674 gfc_trans_scalarizing_loops (&loop
, &body
);
6676 /* Wrap the whole thing up. */
6677 gfc_add_block_to_block (&block
, &loop
.pre
);
6678 gfc_add_block_to_block (&block
, &loop
.post
);
6680 gcc_assert (lss_array
->shape
!= NULL
);
6681 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6682 gfc_cleanup_loop (&loop
);
6684 return gfc_finish_block (&block
);
6689 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6699 gfc_expr
*arg
= NULL
;
6701 gfc_start_block (&block
);
6702 gfc_init_se (&se
, NULL
);
6704 /* Get the descriptor for the expressions. */
6705 se
.want_pointer
= 0;
6706 gfc_conv_expr_descriptor (&se
, expr
);
6707 gfc_add_block_to_block (&block
, &se
.pre
);
6708 gfc_add_modify (&block
, dest
, se
.expr
);
6710 /* Deal with arrays of derived types with allocatable components. */
6711 if (cm
->ts
.type
== BT_DERIVED
6712 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6713 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6716 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6717 && CLASS_DATA(cm
)->attr
.allocatable
)
6719 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6720 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6725 tmp
= TREE_TYPE (dest
);
6726 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6727 tmp
, expr
->rank
, NULL_TREE
);
6731 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6732 TREE_TYPE(cm
->backend_decl
),
6733 cm
->as
->rank
, NULL_TREE
);
6735 gfc_add_expr_to_block (&block
, tmp
);
6736 gfc_add_block_to_block (&block
, &se
.post
);
6738 if (expr
->expr_type
!= EXPR_VARIABLE
)
6739 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6742 /* We need to know if the argument of a conversion function is a
6743 variable, so that the correct lower bound can be used. */
6744 if (expr
->expr_type
== EXPR_FUNCTION
6745 && expr
->value
.function
.isym
6746 && expr
->value
.function
.isym
->conversion
6747 && expr
->value
.function
.actual
->expr
6748 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6749 arg
= expr
->value
.function
.actual
->expr
;
6751 /* Obtain the array spec of full array references. */
6753 as
= gfc_get_full_arrayspec_from_expr (arg
);
6755 as
= gfc_get_full_arrayspec_from_expr (expr
);
6757 /* Shift the lbound and ubound of temporaries to being unity,
6758 rather than zero, based. Always calculate the offset. */
6759 offset
= gfc_conv_descriptor_offset_get (dest
);
6760 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6761 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6763 for (n
= 0; n
< expr
->rank
; n
++)
6768 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6769 TODO It looks as if gfc_conv_expr_descriptor should return
6770 the correct bounds and that the following should not be
6771 necessary. This would simplify gfc_conv_intrinsic_bound
6773 if (as
&& as
->lower
[n
])
6776 gfc_init_se (&lbse
, NULL
);
6777 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6778 gfc_add_block_to_block (&block
, &lbse
.pre
);
6779 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6783 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6784 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6788 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6791 lbound
= gfc_index_one_node
;
6793 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6795 /* Shift the bounds and set the offset accordingly. */
6796 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6797 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6798 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6799 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6801 gfc_conv_descriptor_ubound_set (&block
, dest
,
6802 gfc_rank_cst
[n
], tmp
);
6803 gfc_conv_descriptor_lbound_set (&block
, dest
,
6804 gfc_rank_cst
[n
], lbound
);
6806 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6807 gfc_conv_descriptor_lbound_get (dest
,
6809 gfc_conv_descriptor_stride_get (dest
,
6811 gfc_add_modify (&block
, tmp2
, tmp
);
6812 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6814 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6819 /* If a conversion expression has a null data pointer
6820 argument, nullify the allocatable component. */
6824 if (arg
->symtree
->n
.sym
->attr
.allocatable
6825 || arg
->symtree
->n
.sym
->attr
.pointer
)
6827 non_null_expr
= gfc_finish_block (&block
);
6828 gfc_start_block (&block
);
6829 gfc_conv_descriptor_data_set (&block
, dest
,
6831 null_expr
= gfc_finish_block (&block
);
6832 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6833 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6834 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6835 return build3_v (COND_EXPR
, tmp
,
6836 null_expr
, non_null_expr
);
6840 return gfc_finish_block (&block
);
6844 /* Allocate or reallocate scalar component, as necessary. */
6847 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6857 tree lhs_cl_size
= NULL_TREE
;
6862 if (!expr2
|| expr2
->rank
)
6865 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6867 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6869 char name
[GFC_MAX_SYMBOL_LEN
+9];
6870 gfc_component
*strlen
;
6871 /* Use the rhs string length and the lhs element size. */
6872 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6873 if (!expr2
->ts
.u
.cl
->backend_decl
)
6875 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6876 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6879 size
= expr2
->ts
.u
.cl
->backend_decl
;
6881 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6883 sprintf (name
, "_%s_length", cm
->name
);
6884 strlen
= gfc_find_component (sym
, name
, true, true);
6885 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6886 gfc_charlen_type_node
,
6887 TREE_OPERAND (comp
, 0),
6888 strlen
->backend_decl
, NULL_TREE
);
6890 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6891 tmp
= TYPE_SIZE_UNIT (tmp
);
6892 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6893 TREE_TYPE (tmp
), tmp
,
6894 fold_convert (TREE_TYPE (tmp
), size
));
6898 /* Otherwise use the length in bytes of the rhs. */
6899 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6900 size_in_bytes
= size
;
6903 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6904 size_in_bytes
, size_one_node
);
6906 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6908 tmp
= build_call_expr_loc (input_location
,
6909 builtin_decl_explicit (BUILT_IN_CALLOC
),
6910 2, build_one_cst (size_type_node
),
6912 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6913 gfc_add_modify (block
, comp
, tmp
);
6917 tmp
= build_call_expr_loc (input_location
,
6918 builtin_decl_explicit (BUILT_IN_MALLOC
),
6920 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6921 ptr
= gfc_class_data_get (comp
);
6924 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6925 gfc_add_modify (block
, ptr
, tmp
);
6928 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6929 /* Update the lhs character length. */
6930 gfc_add_modify (block
, lhs_cl_size
, size
);
6934 /* Assign a single component of a derived type constructor. */
6937 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6938 gfc_symbol
*sym
, bool init
)
6946 gfc_start_block (&block
);
6948 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6950 /* Only care about pointers here, not about allocatables. */
6951 gfc_init_se (&se
, NULL
);
6952 /* Pointer component. */
6953 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6954 && !cm
->attr
.proc_pointer
)
6956 /* Array pointer. */
6957 if (expr
->expr_type
== EXPR_NULL
)
6958 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6961 se
.direct_byref
= 1;
6963 gfc_conv_expr_descriptor (&se
, expr
);
6964 gfc_add_block_to_block (&block
, &se
.pre
);
6965 gfc_add_block_to_block (&block
, &se
.post
);
6970 /* Scalar pointers. */
6971 se
.want_pointer
= 1;
6972 gfc_conv_expr (&se
, expr
);
6973 gfc_add_block_to_block (&block
, &se
.pre
);
6975 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6976 && expr
->symtree
->n
.sym
->attr
.dummy
)
6977 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6979 gfc_add_modify (&block
, dest
,
6980 fold_convert (TREE_TYPE (dest
), se
.expr
));
6981 gfc_add_block_to_block (&block
, &se
.post
);
6984 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6986 /* NULL initialization for CLASS components. */
6987 tmp
= gfc_trans_structure_assign (dest
,
6988 gfc_class_initializer (&cm
->ts
, expr
),
6990 gfc_add_expr_to_block (&block
, tmp
);
6992 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6993 && !cm
->attr
.proc_pointer
)
6995 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6996 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6997 else if (cm
->attr
.allocatable
)
6999 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7000 gfc_add_expr_to_block (&block
, tmp
);
7004 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7005 gfc_add_expr_to_block (&block
, tmp
);
7008 else if (cm
->ts
.type
== BT_CLASS
7009 && CLASS_DATA (cm
)->attr
.dimension
7010 && CLASS_DATA (cm
)->attr
.allocatable
7011 && expr
->ts
.type
== BT_DERIVED
)
7013 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7014 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7015 tmp
= gfc_class_vptr_get (dest
);
7016 gfc_add_modify (&block
, tmp
,
7017 fold_convert (TREE_TYPE (tmp
), vtab
));
7018 tmp
= gfc_class_data_get (dest
);
7019 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7020 gfc_add_expr_to_block (&block
, tmp
);
7022 else if (init
&& (cm
->attr
.allocatable
7023 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
7025 /* Take care about non-array allocatable components here. The alloc_*
7026 routine below is motivated by the alloc_scalar_allocatable_for_
7027 assignment() routine, but with the realloc portions removed and
7029 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7034 /* The remainder of these instructions follow the if (cm->attr.pointer)
7035 if (!cm->attr.dimension) part above. */
7036 gfc_init_se (&se
, NULL
);
7037 gfc_conv_expr (&se
, expr
);
7038 gfc_add_block_to_block (&block
, &se
.pre
);
7040 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7041 && expr
->symtree
->n
.sym
->attr
.dummy
)
7042 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7044 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7046 tmp
= gfc_class_data_get (dest
);
7047 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7048 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7049 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7050 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7051 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7054 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7056 /* For deferred strings insert a memcpy. */
7057 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7060 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7061 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7063 : expr
->ts
.u
.cl
->backend_decl
);
7064 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7065 gfc_add_expr_to_block (&block
, tmp
);
7068 gfc_add_modify (&block
, tmp
,
7069 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7070 gfc_add_block_to_block (&block
, &se
.post
);
7072 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7074 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7076 tree dealloc
= NULL_TREE
;
7077 gfc_init_se (&se
, NULL
);
7078 gfc_conv_expr (&se
, expr
);
7079 gfc_add_block_to_block (&block
, &se
.pre
);
7080 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7081 expression in a temporary variable and deallocate the allocatable
7082 components. Then we can the copy the expression to the result. */
7083 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7084 && expr
->expr_type
!= EXPR_VARIABLE
)
7086 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7087 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7090 gfc_add_modify (&block
, dest
,
7091 fold_convert (TREE_TYPE (dest
), se
.expr
));
7092 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7093 && expr
->expr_type
!= EXPR_NULL
)
7095 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7097 gfc_add_expr_to_block (&block
, tmp
);
7098 if (dealloc
!= NULL_TREE
)
7099 gfc_add_expr_to_block (&block
, dealloc
);
7101 gfc_add_block_to_block (&block
, &se
.post
);
7105 /* Nested constructors. */
7106 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7107 gfc_add_expr_to_block (&block
, tmp
);
7110 else if (gfc_deferred_strlen (cm
, &tmp
))
7114 gcc_assert (strlen
);
7115 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7117 TREE_OPERAND (dest
, 0),
7120 if (expr
->expr_type
== EXPR_NULL
)
7122 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7123 gfc_add_modify (&block
, dest
, tmp
);
7124 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7125 gfc_add_modify (&block
, strlen
, tmp
);
7130 gfc_init_se (&se
, NULL
);
7131 gfc_conv_expr (&se
, expr
);
7132 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7133 tmp
= build_call_expr_loc (input_location
,
7134 builtin_decl_explicit (BUILT_IN_MALLOC
),
7136 gfc_add_modify (&block
, dest
,
7137 fold_convert (TREE_TYPE (dest
), tmp
));
7138 gfc_add_modify (&block
, strlen
, se
.string_length
);
7139 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7140 gfc_add_expr_to_block (&block
, tmp
);
7143 else if (!cm
->attr
.artificial
)
7145 /* Scalar component (excluding deferred parameters). */
7146 gfc_init_se (&se
, NULL
);
7147 gfc_init_se (&lse
, NULL
);
7149 gfc_conv_expr (&se
, expr
);
7150 if (cm
->ts
.type
== BT_CHARACTER
)
7151 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7153 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
7154 gfc_add_expr_to_block (&block
, tmp
);
7156 return gfc_finish_block (&block
);
7159 /* Assign a derived type constructor to a variable. */
7162 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7170 gfc_start_block (&block
);
7171 cm
= expr
->ts
.u
.derived
->components
;
7173 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7174 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7175 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7179 gcc_assert (cm
->backend_decl
== NULL
);
7180 gfc_init_se (&se
, NULL
);
7181 gfc_init_se (&lse
, NULL
);
7182 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7184 gfc_add_modify (&block
, lse
.expr
,
7185 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7187 return gfc_finish_block (&block
);
7190 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7191 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7193 /* Skip absent members in default initializers. */
7194 if (!c
->expr
&& !cm
->attr
.allocatable
)
7197 field
= cm
->backend_decl
;
7198 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7199 dest
, field
, NULL_TREE
);
7202 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7203 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7208 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7209 expr
->ts
.u
.derived
, init
);
7210 gfc_add_expr_to_block (&block
, tmp
);
7212 return gfc_finish_block (&block
);
7215 /* Build an expression for a constructor. If init is nonzero then
7216 this is part of a static variable initializer. */
7219 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7226 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7228 gcc_assert (se
->ss
== NULL
);
7229 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7230 type
= gfc_typenode_for_spec (&expr
->ts
);
7234 /* Create a temporary variable and fill it in. */
7235 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7236 /* The symtree in expr is NULL, if the code to generate is for
7237 initializing the static members only. */
7238 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7239 gfc_add_expr_to_block (&se
->pre
, tmp
);
7243 cm
= expr
->ts
.u
.derived
->components
;
7245 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7246 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7248 /* Skip absent members in default initializers and allocatable
7249 components. Although the latter have a default initializer
7250 of EXPR_NULL,... by default, the static nullify is not needed
7251 since this is done every time we come into scope. */
7252 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7255 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7256 && strcmp (cm
->name
, "_extends") == 0
7257 && cm
->initializer
->symtree
)
7261 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7262 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7263 vtab
= unshare_expr_without_location (vtab
);
7264 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7266 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7268 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7269 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7270 fold_convert (TREE_TYPE (cm
->backend_decl
),
7273 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7274 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7275 fold_convert (TREE_TYPE (cm
->backend_decl
),
7276 integer_zero_node
));
7279 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7280 TREE_TYPE (cm
->backend_decl
),
7281 cm
->attr
.dimension
, cm
->attr
.pointer
,
7282 cm
->attr
.proc_pointer
);
7283 val
= unshare_expr_without_location (val
);
7285 /* Append it to the constructor list. */
7286 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7289 se
->expr
= build_constructor (type
, v
);
7291 TREE_CONSTANT (se
->expr
) = 1;
7295 /* Translate a substring expression. */
7298 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7304 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7306 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7307 expr
->value
.character
.length
,
7308 expr
->value
.character
.string
);
7310 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7311 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7314 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7318 /* Entry point for expression translation. Evaluates a scalar quantity.
7319 EXPR is the expression to be translated, and SE is the state structure if
7320 called from within the scalarized. */
7323 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7328 if (ss
&& ss
->info
->expr
== expr
7329 && (ss
->info
->type
== GFC_SS_SCALAR
7330 || ss
->info
->type
== GFC_SS_REFERENCE
))
7332 gfc_ss_info
*ss_info
;
7335 /* Substitute a scalar expression evaluated outside the scalarization
7337 se
->expr
= ss_info
->data
.scalar
.value
;
7338 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7339 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7341 se
->string_length
= ss_info
->string_length
;
7342 gfc_advance_se_ss_chain (se
);
7346 /* We need to convert the expressions for the iso_c_binding derived types.
7347 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7348 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7349 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7350 updated to be an integer with a kind equal to the size of a (void *). */
7351 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7352 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7354 if (expr
->expr_type
== EXPR_VARIABLE
7355 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7356 || expr
->symtree
->n
.sym
->intmod_sym_id
7357 == ISOCBINDING_NULL_FUNPTR
))
7359 /* Set expr_type to EXPR_NULL, which will result in
7360 null_pointer_node being used below. */
7361 expr
->expr_type
= EXPR_NULL
;
7365 /* Update the type/kind of the expression to be what the new
7366 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7367 expr
->ts
.type
= BT_INTEGER
;
7368 expr
->ts
.f90_type
= BT_VOID
;
7369 expr
->ts
.kind
= gfc_index_integer_kind
;
7373 gfc_fix_class_refs (expr
);
7375 switch (expr
->expr_type
)
7378 gfc_conv_expr_op (se
, expr
);
7382 gfc_conv_function_expr (se
, expr
);
7386 gfc_conv_constant (se
, expr
);
7390 gfc_conv_variable (se
, expr
);
7394 se
->expr
= null_pointer_node
;
7397 case EXPR_SUBSTRING
:
7398 gfc_conv_substring_expr (se
, expr
);
7401 case EXPR_STRUCTURE
:
7402 gfc_conv_structure (se
, expr
, 0);
7406 gfc_conv_array_constructor_expr (se
, expr
);
7415 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7416 of an assignment. */
7418 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7420 gfc_conv_expr (se
, expr
);
7421 /* All numeric lvalues should have empty post chains. If not we need to
7422 figure out a way of rewriting an lvalue so that it has no post chain. */
7423 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7426 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7427 numeric expressions. Used for scalar values where inserting cleanup code
7430 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7434 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7435 gfc_conv_expr (se
, expr
);
7438 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7439 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7441 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7445 /* Helper to translate an expression and convert it to a particular type. */
7447 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7449 gfc_conv_expr_val (se
, expr
);
7450 se
->expr
= convert (type
, se
->expr
);
7454 /* Converts an expression so that it can be passed by reference. Scalar
7458 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7464 if (ss
&& ss
->info
->expr
== expr
7465 && ss
->info
->type
== GFC_SS_REFERENCE
)
7467 /* Returns a reference to the scalar evaluated outside the loop
7469 gfc_conv_expr (se
, expr
);
7471 if (expr
->ts
.type
== BT_CHARACTER
7472 && expr
->expr_type
!= EXPR_FUNCTION
)
7473 gfc_conv_string_parameter (se
);
7475 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7480 if (expr
->ts
.type
== BT_CHARACTER
)
7482 gfc_conv_expr (se
, expr
);
7483 gfc_conv_string_parameter (se
);
7487 if (expr
->expr_type
== EXPR_VARIABLE
)
7489 se
->want_pointer
= 1;
7490 gfc_conv_expr (se
, expr
);
7493 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7494 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7495 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7501 if (expr
->expr_type
== EXPR_FUNCTION
7502 && ((expr
->value
.function
.esym
7503 && expr
->value
.function
.esym
->result
->attr
.pointer
7504 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7505 || (!expr
->value
.function
.esym
&& !expr
->ref
7506 && expr
->symtree
->n
.sym
->attr
.pointer
7507 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7509 se
->want_pointer
= 1;
7510 gfc_conv_expr (se
, expr
);
7511 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7512 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7517 gfc_conv_expr (se
, expr
);
7519 /* Create a temporary var to hold the value. */
7520 if (TREE_CONSTANT (se
->expr
))
7522 tree tmp
= se
->expr
;
7523 STRIP_TYPE_NOPS (tmp
);
7524 var
= build_decl (input_location
,
7525 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7526 DECL_INITIAL (var
) = tmp
;
7527 TREE_STATIC (var
) = 1;
7532 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7533 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7535 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7537 /* Take the address of that value. */
7538 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7539 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7540 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7541 && expr
->ts
.u
.derived
->attr
.alloc_comp
7542 && expr
->expr_type
!= EXPR_VARIABLE
)
7546 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7547 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7549 /* The components shall be deallocated before
7550 their containing entity. */
7551 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7557 gfc_trans_pointer_assign (gfc_code
* code
)
7559 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7563 /* Generate code for a pointer assignment. */
7566 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7568 gfc_expr
*expr1_vptr
= NULL
;
7578 gfc_start_block (&block
);
7580 gfc_init_se (&lse
, NULL
);
7582 /* Check whether the expression is a scalar or not; we cannot use
7583 expr1->rank as it can be nonzero for proc pointers. */
7584 ss
= gfc_walk_expr (expr1
);
7585 scalar
= ss
== gfc_ss_terminator
;
7587 gfc_free_ss_chain (ss
);
7589 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7590 && expr2
->expr_type
!= EXPR_FUNCTION
)
7592 gfc_add_data_component (expr2
);
7593 /* The following is required as gfc_add_data_component doesn't
7594 update ts.type if there is a tailing REF_ARRAY. */
7595 expr2
->ts
.type
= BT_DERIVED
;
7600 /* Scalar pointers. */
7601 lse
.want_pointer
= 1;
7602 gfc_conv_expr (&lse
, expr1
);
7603 gfc_init_se (&rse
, NULL
);
7604 rse
.want_pointer
= 1;
7605 gfc_conv_expr (&rse
, expr2
);
7607 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7608 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7609 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7612 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7613 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7614 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7617 gfc_add_block_to_block (&block
, &lse
.pre
);
7618 gfc_add_block_to_block (&block
, &rse
.pre
);
7620 /* For string assignments to unlimited polymorphic pointers add an
7621 assignment of the string_length to the _len component of the
7623 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7624 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7625 && (expr2
->ts
.type
== BT_CHARACTER
||
7626 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7627 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7631 len_comp
= gfc_get_len_component (expr1
);
7632 gfc_init_se (&se
, NULL
);
7633 gfc_conv_expr (&se
, len_comp
);
7635 /* ptr % _len = len (str) */
7636 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7637 lse
.string_length
= se
.expr
;
7638 gfc_free_expr (len_comp
);
7641 /* Check character lengths if character expression. The test is only
7642 really added if -fbounds-check is enabled. Exclude deferred
7643 character length lefthand sides. */
7644 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7645 && !expr1
->ts
.deferred
7646 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7647 && !gfc_is_proc_ptr_comp (expr1
))
7649 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7650 gcc_assert (lse
.string_length
&& rse
.string_length
);
7651 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7652 lse
.string_length
, rse
.string_length
,
7656 /* The assignment to an deferred character length sets the string
7657 length to that of the rhs. */
7658 if (expr1
->ts
.deferred
)
7660 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7661 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7662 else if (lse
.string_length
!= NULL
)
7663 gfc_add_modify (&block
, lse
.string_length
,
7664 build_int_cst (gfc_charlen_type_node
, 0));
7667 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7668 rse
.expr
= gfc_class_data_get (rse
.expr
);
7670 gfc_add_modify (&block
, lse
.expr
,
7671 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7673 gfc_add_block_to_block (&block
, &rse
.post
);
7674 gfc_add_block_to_block (&block
, &lse
.post
);
7681 tree strlen_rhs
= NULL_TREE
;
7683 /* Array pointer. Find the last reference on the LHS and if it is an
7684 array section ref, we're dealing with bounds remapping. In this case,
7685 set it to AR_FULL so that gfc_conv_expr_descriptor does
7686 not see it and process the bounds remapping afterwards explicitly. */
7687 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7688 if (!remap
->next
&& remap
->type
== REF_ARRAY
7689 && remap
->u
.ar
.type
== AR_SECTION
)
7691 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7693 gfc_init_se (&lse
, NULL
);
7695 lse
.descriptor_only
= 1;
7696 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7697 && expr1
->ts
.type
== BT_CLASS
)
7698 expr1_vptr
= gfc_copy_expr (expr1
);
7699 gfc_conv_expr_descriptor (&lse
, expr1
);
7700 strlen_lhs
= lse
.string_length
;
7703 if (expr2
->expr_type
== EXPR_NULL
)
7705 /* Just set the data pointer to null. */
7706 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7708 else if (rank_remap
)
7710 /* If we are rank-remapping, just get the RHS's descriptor and
7711 process this later on. */
7712 gfc_init_se (&rse
, NULL
);
7713 rse
.direct_byref
= 1;
7714 rse
.byref_noassign
= 1;
7716 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7718 gfc_conv_function_expr (&rse
, expr2
);
7720 if (expr1
->ts
.type
!= BT_CLASS
)
7721 rse
.expr
= gfc_class_data_get (rse
.expr
);
7724 gfc_add_block_to_block (&block
, &rse
.pre
);
7725 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7726 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7728 gfc_add_vptr_component (expr1_vptr
);
7729 gfc_init_se (&rse
, NULL
);
7730 rse
.want_pointer
= 1;
7731 gfc_conv_expr (&rse
, expr1_vptr
);
7732 gfc_add_modify (&lse
.pre
, rse
.expr
,
7733 fold_convert (TREE_TYPE (rse
.expr
),
7734 gfc_class_vptr_get (tmp
)));
7735 rse
.expr
= gfc_class_data_get (tmp
);
7738 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7740 tree bound
[GFC_MAX_DIMENSIONS
];
7743 for (i
= 0; i
< expr2
->rank
; i
++)
7744 bound
[i
] = NULL_TREE
;
7745 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7746 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7748 GFC_ARRAY_POINTER_CONT
, false);
7749 tmp
= gfc_create_var (tmp
, "ptrtemp");
7750 lse
.descriptor_only
= 0;
7752 lse
.direct_byref
= 1;
7753 gfc_conv_expr_descriptor (&lse
, expr2
);
7754 strlen_rhs
= lse
.string_length
;
7759 gfc_conv_expr_descriptor (&rse
, expr2
);
7760 strlen_rhs
= rse
.string_length
;
7763 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7765 /* Assign directly to the LHS's descriptor. */
7766 lse
.descriptor_only
= 0;
7767 lse
.direct_byref
= 1;
7768 gfc_conv_expr_descriptor (&lse
, expr2
);
7769 strlen_rhs
= lse
.string_length
;
7771 /* If this is a subreference array pointer assignment, use the rhs
7772 descriptor element size for the lhs span. */
7773 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7775 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7776 gfc_init_se (&rse
, NULL
);
7777 rse
.descriptor_only
= 1;
7778 gfc_conv_expr (&rse
, expr2
);
7779 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7780 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7781 if (!INTEGER_CST_P (tmp
))
7782 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7783 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7786 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7788 gfc_init_se (&rse
, NULL
);
7789 rse
.want_pointer
= 1;
7790 gfc_conv_function_expr (&rse
, expr2
);
7791 if (expr1
->ts
.type
!= BT_CLASS
)
7793 rse
.expr
= gfc_class_data_get (rse
.expr
);
7794 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7798 gfc_add_block_to_block (&block
, &rse
.pre
);
7799 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7800 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7802 gfc_add_vptr_component (expr1_vptr
);
7803 gfc_init_se (&rse
, NULL
);
7804 rse
.want_pointer
= 1;
7805 gfc_conv_expr (&rse
, expr1_vptr
);
7806 gfc_add_modify (&lse
.pre
, rse
.expr
,
7807 fold_convert (TREE_TYPE (rse
.expr
),
7808 gfc_class_vptr_get (tmp
)));
7809 rse
.expr
= gfc_class_data_get (tmp
);
7810 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7815 /* Assign to a temporary descriptor and then copy that
7816 temporary to the pointer. */
7817 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7818 lse
.descriptor_only
= 0;
7820 lse
.direct_byref
= 1;
7821 gfc_conv_expr_descriptor (&lse
, expr2
);
7822 strlen_rhs
= lse
.string_length
;
7823 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7827 gfc_free_expr (expr1_vptr
);
7829 gfc_add_block_to_block (&block
, &lse
.pre
);
7831 gfc_add_block_to_block (&block
, &rse
.pre
);
7833 /* If we do bounds remapping, update LHS descriptor accordingly. */
7837 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7841 /* Do rank remapping. We already have the RHS's descriptor
7842 converted in rse and now have to build the correct LHS
7843 descriptor for it. */
7847 tree lbound
, ubound
;
7850 dtype
= gfc_conv_descriptor_dtype (desc
);
7851 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7852 gfc_add_modify (&block
, dtype
, tmp
);
7854 /* Copy data pointer. */
7855 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7856 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7858 /* Copy offset but adjust it such that it would correspond
7859 to a lbound of zero. */
7860 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7861 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7863 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7865 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7867 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7868 gfc_array_index_type
, stride
, lbound
);
7869 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7870 gfc_array_index_type
, offs
, tmp
);
7872 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7874 /* Set the bounds as declared for the LHS and calculate strides as
7875 well as another offset update accordingly. */
7876 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7878 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7883 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7885 /* Convert declared bounds. */
7886 gfc_init_se (&lower_se
, NULL
);
7887 gfc_init_se (&upper_se
, NULL
);
7888 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7889 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7891 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7892 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7894 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7895 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7897 lbound
= gfc_evaluate_now (lbound
, &block
);
7898 ubound
= gfc_evaluate_now (ubound
, &block
);
7900 gfc_add_block_to_block (&block
, &lower_se
.post
);
7901 gfc_add_block_to_block (&block
, &upper_se
.post
);
7903 /* Set bounds in descriptor. */
7904 gfc_conv_descriptor_lbound_set (&block
, desc
,
7905 gfc_rank_cst
[dim
], lbound
);
7906 gfc_conv_descriptor_ubound_set (&block
, desc
,
7907 gfc_rank_cst
[dim
], ubound
);
7910 stride
= gfc_evaluate_now (stride
, &block
);
7911 gfc_conv_descriptor_stride_set (&block
, desc
,
7912 gfc_rank_cst
[dim
], stride
);
7914 /* Update offset. */
7915 offs
= gfc_conv_descriptor_offset_get (desc
);
7916 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7917 gfc_array_index_type
, lbound
, stride
);
7918 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7919 gfc_array_index_type
, offs
, tmp
);
7920 offs
= gfc_evaluate_now (offs
, &block
);
7921 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7923 /* Update stride. */
7924 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7925 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7926 gfc_array_index_type
, stride
, tmp
);
7931 /* Bounds remapping. Just shift the lower bounds. */
7933 gcc_assert (expr1
->rank
== expr2
->rank
);
7935 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7939 gcc_assert (remap
->u
.ar
.start
[dim
]);
7940 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7941 gfc_init_se (&lbound_se
, NULL
);
7942 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7944 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7945 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7946 dim
, lbound_se
.expr
);
7947 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7952 /* Check string lengths if applicable. The check is only really added
7953 to the output code if -fbounds-check is enabled. */
7954 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7956 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7957 gcc_assert (strlen_lhs
&& strlen_rhs
);
7958 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7959 strlen_lhs
, strlen_rhs
, &block
);
7962 /* If rank remapping was done, check with -fcheck=bounds that
7963 the target is at least as large as the pointer. */
7964 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7970 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7971 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7973 lsize
= gfc_evaluate_now (lsize
, &block
);
7974 rsize
= gfc_evaluate_now (rsize
, &block
);
7975 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7978 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7979 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7983 gfc_add_block_to_block (&block
, &lse
.post
);
7985 gfc_add_block_to_block (&block
, &rse
.post
);
7988 return gfc_finish_block (&block
);
7992 /* Makes sure se is suitable for passing as a function string parameter. */
7993 /* TODO: Need to check all callers of this function. It may be abused. */
7996 gfc_conv_string_parameter (gfc_se
* se
)
8000 if (TREE_CODE (se
->expr
) == STRING_CST
)
8002 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8003 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8007 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8009 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8011 type
= TREE_TYPE (se
->expr
);
8012 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8016 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8018 type
= build_pointer_type (type
);
8019 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8023 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8027 /* Generate code for assignment of scalar variables. Includes character
8028 strings and derived types with allocatable components.
8029 If you know that the LHS has no allocations, set dealloc to false.
8031 DEEP_COPY has no effect if the typespec TS is not a derived type with
8032 allocatable components. Otherwise, if it is set, an explicit copy of each
8033 allocatable component is made. This is necessary as a simple copy of the
8034 whole object would copy array descriptors as is, so that the lhs's
8035 allocatable components would point to the rhs's after the assignment.
8036 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8037 necessary if the rhs is a non-pointer function, as the allocatable components
8038 are not accessible by other means than the function's result after the
8039 function has returned. It is even more subtle when temporaries are involved,
8040 as the two following examples show:
8041 1. When we evaluate an array constructor, a temporary is created. Thus
8042 there is theoretically no alias possible. However, no deep copy is
8043 made for this temporary, so that if the constructor is made of one or
8044 more variable with allocatable components, those components still point
8045 to the variable's: DEEP_COPY should be set for the assignment from the
8046 temporary to the lhs in that case.
8047 2. When assigning a scalar to an array, we evaluate the scalar value out
8048 of the loop, store it into a temporary variable, and assign from that.
8049 In that case, deep copying when assigning to the temporary would be a
8050 waste of resources; however deep copies should happen when assigning from
8051 the temporary to each array element: again DEEP_COPY should be set for
8052 the assignment from the temporary to the lhs. */
8055 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8056 bool l_is_temp
, bool deep_copy
, bool dealloc
)
8062 gfc_init_block (&block
);
8064 if (ts
.type
== BT_CHARACTER
)
8069 if (lse
->string_length
!= NULL_TREE
)
8071 gfc_conv_string_parameter (lse
);
8072 gfc_add_block_to_block (&block
, &lse
->pre
);
8073 llen
= lse
->string_length
;
8076 if (rse
->string_length
!= NULL_TREE
)
8078 gcc_assert (rse
->string_length
!= NULL_TREE
);
8079 gfc_conv_string_parameter (rse
);
8080 gfc_add_block_to_block (&block
, &rse
->pre
);
8081 rlen
= rse
->string_length
;
8084 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8085 rse
->expr
, ts
.kind
);
8087 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8089 tree tmp_var
= NULL_TREE
;
8092 /* Are the rhs and the lhs the same? */
8095 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8096 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8097 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8098 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8101 /* Deallocate the lhs allocated components as long as it is not
8102 the same as the rhs. This must be done following the assignment
8103 to prevent deallocating data that could be used in the rhs
8105 if (!l_is_temp
&& dealloc
)
8107 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8108 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8110 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8112 gfc_add_expr_to_block (&lse
->post
, tmp
);
8115 gfc_add_block_to_block (&block
, &rse
->pre
);
8116 gfc_add_block_to_block (&block
, &lse
->pre
);
8118 gfc_add_modify (&block
, lse
->expr
,
8119 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8121 /* Restore pointer address of coarray components. */
8122 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8124 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8125 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8127 gfc_add_expr_to_block (&block
, tmp
);
8130 /* Do a deep copy if the rhs is a variable, if it is not the
8134 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8135 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8137 gfc_add_expr_to_block (&block
, tmp
);
8140 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8142 gfc_add_block_to_block (&block
, &lse
->pre
);
8143 gfc_add_block_to_block (&block
, &rse
->pre
);
8144 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8145 TREE_TYPE (lse
->expr
), rse
->expr
);
8146 gfc_add_modify (&block
, lse
->expr
, tmp
);
8150 gfc_add_block_to_block (&block
, &lse
->pre
);
8151 gfc_add_block_to_block (&block
, &rse
->pre
);
8153 gfc_add_modify (&block
, lse
->expr
,
8154 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8157 gfc_add_block_to_block (&block
, &lse
->post
);
8158 gfc_add_block_to_block (&block
, &rse
->post
);
8160 return gfc_finish_block (&block
);
8164 /* There are quite a lot of restrictions on the optimisation in using an
8165 array function assign without a temporary. */
8168 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8171 bool seen_array_ref
;
8173 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8175 /* Play it safe with class functions assigned to a derived type. */
8176 if (gfc_is_alloc_class_array_function (expr2
)
8177 && expr1
->ts
.type
== BT_DERIVED
)
8180 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8181 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8184 /* Elemental functions are scalarized so that they don't need a
8185 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8186 they would need special treatment in gfc_trans_arrayfunc_assign. */
8187 if (expr2
->value
.function
.esym
!= NULL
8188 && expr2
->value
.function
.esym
->attr
.elemental
)
8191 /* Need a temporary if rhs is not FULL or a contiguous section. */
8192 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8195 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8196 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8199 /* Functions returning pointers or allocatables need temporaries. */
8200 c
= expr2
->value
.function
.esym
8201 ? (expr2
->value
.function
.esym
->attr
.pointer
8202 || expr2
->value
.function
.esym
->attr
.allocatable
)
8203 : (expr2
->symtree
->n
.sym
->attr
.pointer
8204 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8208 /* Character array functions need temporaries unless the
8209 character lengths are the same. */
8210 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8212 if (expr1
->ts
.u
.cl
->length
== NULL
8213 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8216 if (expr2
->ts
.u
.cl
->length
== NULL
8217 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8220 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8221 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8225 /* Check that no LHS component references appear during an array
8226 reference. This is needed because we do not have the means to
8227 span any arbitrary stride with an array descriptor. This check
8228 is not needed for the rhs because the function result has to be
8230 seen_array_ref
= false;
8231 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8233 if (ref
->type
== REF_ARRAY
)
8234 seen_array_ref
= true;
8235 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8239 /* Check for a dependency. */
8240 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8241 expr2
->value
.function
.esym
,
8242 expr2
->value
.function
.actual
,
8246 /* If we have reached here with an intrinsic function, we do not
8247 need a temporary except in the particular case that reallocation
8248 on assignment is active and the lhs is allocatable and a target. */
8249 if (expr2
->value
.function
.isym
)
8250 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8252 /* If the LHS is a dummy, we need a temporary if it is not
8254 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8257 /* If the lhs has been host_associated, is in common, a pointer or is
8258 a target and the function is not using a RESULT variable, aliasing
8259 can occur and a temporary is needed. */
8260 if ((sym
->attr
.host_assoc
8261 || sym
->attr
.in_common
8262 || sym
->attr
.pointer
8263 || sym
->attr
.cray_pointee
8264 || sym
->attr
.target
)
8265 && expr2
->symtree
!= NULL
8266 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8269 /* A PURE function can unconditionally be called without a temporary. */
8270 if (expr2
->value
.function
.esym
!= NULL
8271 && expr2
->value
.function
.esym
->attr
.pure
)
8274 /* Implicit_pure functions are those which could legally be declared
8276 if (expr2
->value
.function
.esym
!= NULL
8277 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8280 if (!sym
->attr
.use_assoc
8281 && !sym
->attr
.in_common
8282 && !sym
->attr
.pointer
8283 && !sym
->attr
.target
8284 && !sym
->attr
.cray_pointee
8285 && expr2
->value
.function
.esym
)
8287 /* A temporary is not needed if the function is not contained and
8288 the variable is local or host associated and not a pointer or
8290 if (!expr2
->value
.function
.esym
->attr
.contained
)
8293 /* A temporary is not needed if the lhs has never been host
8294 associated and the procedure is contained. */
8295 else if (!sym
->attr
.host_assoc
)
8298 /* A temporary is not needed if the variable is local and not
8299 a pointer, a target or a result. */
8301 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8305 /* Default to temporary use. */
8310 /* Provide the loop info so that the lhs descriptor can be built for
8311 reallocatable assignments from extrinsic function calls. */
8314 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8317 /* Signal that the function call should not be made by
8318 gfc_conv_loop_setup. */
8319 se
->ss
->is_alloc_lhs
= 1;
8320 gfc_init_loopinfo (loop
);
8321 gfc_add_ss_to_loop (loop
, *ss
);
8322 gfc_add_ss_to_loop (loop
, se
->ss
);
8323 gfc_conv_ss_startstride (loop
);
8324 gfc_conv_loop_setup (loop
, where
);
8325 gfc_copy_loopinfo_to_se (se
, loop
);
8326 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8327 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8328 se
->ss
->is_alloc_lhs
= 0;
8332 /* For assignment to a reallocatable lhs from intrinsic functions,
8333 replace the se.expr (ie. the result) with a temporary descriptor.
8334 Null the data field so that the library allocates space for the
8335 result. Free the data of the original descriptor after the function,
8336 in case it appears in an argument expression and transfer the
8337 result to the original descriptor. */
8340 fcncall_realloc_result (gfc_se
*se
, int rank
)
8349 /* Use the allocation done by the library. Substitute the lhs
8350 descriptor with a copy, whose data field is nulled.*/
8351 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8352 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8353 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8355 /* Unallocated, the descriptor does not have a dtype. */
8356 tmp
= gfc_conv_descriptor_dtype (desc
);
8357 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8359 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8360 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8361 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8363 /* Free the lhs after the function call and copy the result data to
8364 the lhs descriptor. */
8365 tmp
= gfc_conv_descriptor_data_get (desc
);
8366 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8367 boolean_type_node
, tmp
,
8368 build_int_cst (TREE_TYPE (tmp
), 0));
8369 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8370 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
8371 gfc_add_expr_to_block (&se
->post
, tmp
);
8373 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8374 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8376 /* Check that the shapes are the same between lhs and expression. */
8377 for (n
= 0 ; n
< rank
; n
++)
8380 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8381 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8382 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8383 gfc_array_index_type
, tmp
, tmp1
);
8384 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8385 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8386 gfc_array_index_type
, tmp
, tmp1
);
8387 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8388 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8389 gfc_array_index_type
, tmp
, tmp1
);
8390 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8391 boolean_type_node
, tmp
,
8392 gfc_index_zero_node
);
8393 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8394 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8395 boolean_type_node
, tmp
,
8399 /* 'zero_cond' being true is equal to lhs not being allocated or the
8400 shapes being different. */
8401 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8403 /* Now reset the bounds returned from the function call to bounds based
8404 on the lhs lbounds, except where the lhs is not allocated or the shapes
8405 of 'variable and 'expr' are different. Set the offset accordingly. */
8406 offset
= gfc_index_zero_node
;
8407 for (n
= 0 ; n
< rank
; n
++)
8411 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8412 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8413 gfc_array_index_type
, zero_cond
,
8414 gfc_index_one_node
, lbound
);
8415 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8417 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8418 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8419 gfc_array_index_type
, tmp
, lbound
);
8420 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8421 gfc_rank_cst
[n
], lbound
);
8422 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8423 gfc_rank_cst
[n
], tmp
);
8425 /* Set stride and accumulate the offset. */
8426 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8427 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8428 gfc_rank_cst
[n
], tmp
);
8429 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8430 gfc_array_index_type
, lbound
, tmp
);
8431 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8432 gfc_array_index_type
, offset
, tmp
);
8433 offset
= gfc_evaluate_now (offset
, &se
->post
);
8436 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8441 /* Try to translate array(:) = func (...), where func is a transformational
8442 array function, without using a temporary. Returns NULL if this isn't the
8446 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8450 gfc_component
*comp
= NULL
;
8453 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8456 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8458 comp
= gfc_get_proc_ptr_comp (expr2
);
8459 gcc_assert (expr2
->value
.function
.isym
8460 || (comp
&& comp
->attr
.dimension
)
8461 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8462 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8464 gfc_init_se (&se
, NULL
);
8465 gfc_start_block (&se
.pre
);
8466 se
.want_pointer
= 1;
8468 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8470 if (expr1
->ts
.type
== BT_DERIVED
8471 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8474 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8476 gfc_add_expr_to_block (&se
.pre
, tmp
);
8479 se
.direct_byref
= 1;
8480 se
.ss
= gfc_walk_expr (expr2
);
8481 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8483 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8484 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8485 Clearly, this cannot be done for an allocatable function result, since
8486 the shape of the result is unknown and, in any case, the function must
8487 correctly take care of the reallocation internally. For intrinsic
8488 calls, the array data is freed and the library takes care of allocation.
8489 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8491 if (flag_realloc_lhs
8492 && gfc_is_reallocatable_lhs (expr1
)
8493 && !gfc_expr_attr (expr1
).codimension
8494 && !gfc_is_coindexed (expr1
)
8495 && !(expr2
->value
.function
.esym
8496 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8498 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8500 if (!expr2
->value
.function
.isym
)
8502 ss
= gfc_walk_expr (expr1
);
8503 gcc_assert (ss
!= gfc_ss_terminator
);
8505 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8506 ss
->is_alloc_lhs
= 1;
8509 fcncall_realloc_result (&se
, expr1
->rank
);
8512 gfc_conv_function_expr (&se
, expr2
);
8513 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8516 gfc_cleanup_loop (&loop
);
8518 gfc_free_ss_chain (se
.ss
);
8520 return gfc_finish_block (&se
.pre
);
8524 /* Try to efficiently translate array(:) = 0. Return NULL if this
8528 gfc_trans_zero_assign (gfc_expr
* expr
)
8530 tree dest
, len
, type
;
8534 sym
= expr
->symtree
->n
.sym
;
8535 dest
= gfc_get_symbol_decl (sym
);
8537 type
= TREE_TYPE (dest
);
8538 if (POINTER_TYPE_P (type
))
8539 type
= TREE_TYPE (type
);
8540 if (!GFC_ARRAY_TYPE_P (type
))
8543 /* Determine the length of the array. */
8544 len
= GFC_TYPE_ARRAY_SIZE (type
);
8545 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8548 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8549 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8550 fold_convert (gfc_array_index_type
, tmp
));
8552 /* If we are zeroing a local array avoid taking its address by emitting
8554 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8555 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8556 dest
, build_constructor (TREE_TYPE (dest
),
8559 /* Convert arguments to the correct types. */
8560 dest
= fold_convert (pvoid_type_node
, dest
);
8561 len
= fold_convert (size_type_node
, len
);
8563 /* Construct call to __builtin_memset. */
8564 tmp
= build_call_expr_loc (input_location
,
8565 builtin_decl_explicit (BUILT_IN_MEMSET
),
8566 3, dest
, integer_zero_node
, len
);
8567 return fold_convert (void_type_node
, tmp
);
8571 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8572 that constructs the call to __builtin_memcpy. */
8575 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8579 /* Convert arguments to the correct types. */
8580 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8581 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8583 dst
= fold_convert (pvoid_type_node
, dst
);
8585 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8586 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8588 src
= fold_convert (pvoid_type_node
, src
);
8590 len
= fold_convert (size_type_node
, len
);
8592 /* Construct call to __builtin_memcpy. */
8593 tmp
= build_call_expr_loc (input_location
,
8594 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8596 return fold_convert (void_type_node
, tmp
);
8600 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8601 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8602 source/rhs, both are gfc_full_array_ref_p which have been checked for
8606 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8608 tree dst
, dlen
, dtype
;
8609 tree src
, slen
, stype
;
8612 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8613 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8615 dtype
= TREE_TYPE (dst
);
8616 if (POINTER_TYPE_P (dtype
))
8617 dtype
= TREE_TYPE (dtype
);
8618 stype
= TREE_TYPE (src
);
8619 if (POINTER_TYPE_P (stype
))
8620 stype
= TREE_TYPE (stype
);
8622 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8625 /* Determine the lengths of the arrays. */
8626 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8627 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8629 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8630 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8631 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8633 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8634 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8636 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8637 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8638 slen
, fold_convert (gfc_array_index_type
, tmp
));
8640 /* Sanity check that they are the same. This should always be
8641 the case, as we should already have checked for conformance. */
8642 if (!tree_int_cst_equal (slen
, dlen
))
8645 return gfc_build_memcpy_call (dst
, src
, dlen
);
8649 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8650 this can't be done. EXPR1 is the destination/lhs for which
8651 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8654 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8656 unsigned HOST_WIDE_INT nelem
;
8662 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8666 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8667 dtype
= TREE_TYPE (dst
);
8668 if (POINTER_TYPE_P (dtype
))
8669 dtype
= TREE_TYPE (dtype
);
8670 if (!GFC_ARRAY_TYPE_P (dtype
))
8673 /* Determine the lengths of the array. */
8674 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8675 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8678 /* Confirm that the constructor is the same size. */
8679 if (compare_tree_int (len
, nelem
) != 0)
8682 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8683 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8684 fold_convert (gfc_array_index_type
, tmp
));
8686 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8687 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8689 stype
= TREE_TYPE (src
);
8690 if (POINTER_TYPE_P (stype
))
8691 stype
= TREE_TYPE (stype
);
8693 return gfc_build_memcpy_call (dst
, src
, len
);
8697 /* Tells whether the expression is to be treated as a variable reference. */
8700 expr_is_variable (gfc_expr
*expr
)
8703 gfc_component
*comp
;
8704 gfc_symbol
*func_ifc
;
8706 if (expr
->expr_type
== EXPR_VARIABLE
)
8709 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8712 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8713 return expr_is_variable (arg
);
8716 /* A data-pointer-returning function should be considered as a variable
8718 if (expr
->expr_type
== EXPR_FUNCTION
8719 && expr
->ref
== NULL
)
8721 if (expr
->value
.function
.isym
!= NULL
)
8724 if (expr
->value
.function
.esym
!= NULL
)
8726 func_ifc
= expr
->value
.function
.esym
;
8731 gcc_assert (expr
->symtree
);
8732 func_ifc
= expr
->symtree
->n
.sym
;
8739 comp
= gfc_get_proc_ptr_comp (expr
);
8740 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8743 func_ifc
= comp
->ts
.interface
;
8747 if (expr
->expr_type
== EXPR_COMPCALL
)
8749 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8750 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8757 gcc_assert (func_ifc
->attr
.function
8758 && func_ifc
->result
!= NULL
);
8759 return func_ifc
->result
->attr
.pointer
;
8763 /* Is the lhs OK for automatic reallocation? */
8766 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8770 /* An allocatable variable with no reference. */
8771 if (expr
->symtree
->n
.sym
->attr
.allocatable
8775 /* All that can be left are allocatable components. */
8776 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8777 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8778 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8781 /* Find an allocatable component ref last. */
8782 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8783 if (ref
->type
== REF_COMPONENT
8785 && ref
->u
.c
.component
->attr
.allocatable
)
8792 /* Allocate or reallocate scalar lhs, as necessary. */
8795 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8809 if (!expr1
|| expr1
->rank
)
8812 if (!expr2
|| expr2
->rank
)
8815 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8817 /* Since this is a scalar lhs, we can afford to do this. That is,
8818 there is no risk of side effects being repeated. */
8819 gfc_init_se (&lse
, NULL
);
8820 lse
.want_pointer
= 1;
8821 gfc_conv_expr (&lse
, expr1
);
8823 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8824 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8826 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8827 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8828 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8830 tmp
= build3_v (COND_EXPR
, cond
,
8831 build1_v (GOTO_EXPR
, jump_label1
),
8832 build_empty_stmt (input_location
));
8833 gfc_add_expr_to_block (block
, tmp
);
8835 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8837 /* Use the rhs string length and the lhs element size. */
8838 size
= string_length
;
8839 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8840 tmp
= TYPE_SIZE_UNIT (tmp
);
8841 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8842 TREE_TYPE (tmp
), tmp
,
8843 fold_convert (TREE_TYPE (tmp
), size
));
8847 /* Otherwise use the length in bytes of the rhs. */
8848 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8849 size_in_bytes
= size
;
8852 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8853 size_in_bytes
, size_one_node
);
8855 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8857 tmp
= build_call_expr_loc (input_location
,
8858 builtin_decl_explicit (BUILT_IN_CALLOC
),
8859 2, build_one_cst (size_type_node
),
8861 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8862 gfc_add_modify (block
, lse
.expr
, tmp
);
8866 tmp
= build_call_expr_loc (input_location
,
8867 builtin_decl_explicit (BUILT_IN_MALLOC
),
8869 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8870 gfc_add_modify (block
, lse
.expr
, tmp
);
8873 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8875 /* Deferred characters need checking for lhs and rhs string
8876 length. Other deferred parameter variables will have to
8878 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8879 gfc_add_expr_to_block (block
, tmp
);
8881 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8882 gfc_add_expr_to_block (block
, tmp
);
8884 /* For a deferred length character, reallocate if lengths of lhs and
8885 rhs are different. */
8886 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8888 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8889 lse
.string_length
, size
);
8890 /* Jump past the realloc if the lengths are the same. */
8891 tmp
= build3_v (COND_EXPR
, cond
,
8892 build1_v (GOTO_EXPR
, jump_label2
),
8893 build_empty_stmt (input_location
));
8894 gfc_add_expr_to_block (block
, tmp
);
8895 tmp
= build_call_expr_loc (input_location
,
8896 builtin_decl_explicit (BUILT_IN_REALLOC
),
8897 2, fold_convert (pvoid_type_node
, lse
.expr
),
8899 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8900 gfc_add_modify (block
, lse
.expr
, tmp
);
8901 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8902 gfc_add_expr_to_block (block
, tmp
);
8904 /* Update the lhs character length. */
8905 size
= string_length
;
8906 gfc_add_modify (block
, lse
.string_length
, size
);
8910 /* Check for assignments of the type
8914 to make sure we do not check for reallocation unneccessarily. */
8918 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8920 gfc_actual_arglist
*a
;
8923 switch (expr2
->expr_type
)
8926 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8929 if (expr2
->value
.function
.esym
8930 && expr2
->value
.function
.esym
->attr
.elemental
)
8932 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8935 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8940 else if (expr2
->value
.function
.isym
8941 && expr2
->value
.function
.isym
->elemental
)
8943 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8946 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8955 switch (expr2
->value
.op
.op
)
8958 case INTRINSIC_UPLUS
:
8959 case INTRINSIC_UMINUS
:
8960 case INTRINSIC_PARENTHESES
:
8961 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8963 case INTRINSIC_PLUS
:
8964 case INTRINSIC_MINUS
:
8965 case INTRINSIC_TIMES
:
8966 case INTRINSIC_DIVIDE
:
8967 case INTRINSIC_POWER
:
8971 case INTRINSIC_NEQV
:
8978 case INTRINSIC_EQ_OS
:
8979 case INTRINSIC_NE_OS
:
8980 case INTRINSIC_GT_OS
:
8981 case INTRINSIC_GE_OS
:
8982 case INTRINSIC_LT_OS
:
8983 case INTRINSIC_LE_OS
:
8985 e1
= expr2
->value
.op
.op1
;
8986 e2
= expr2
->value
.op
.op2
;
8988 if (e1
->rank
== 0 && e2
->rank
> 0)
8989 return is_runtime_conformable (expr1
, e2
);
8990 else if (e1
->rank
> 0 && e2
->rank
== 0)
8991 return is_runtime_conformable (expr1
, e1
);
8992 else if (e1
->rank
> 0 && e2
->rank
> 0)
8993 return is_runtime_conformable (expr1
, e1
)
8994 && is_runtime_conformable (expr1
, e2
);
9010 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9011 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9012 init_flag indicates initialization expressions and dealloc that no
9013 deallocate prior assignment is needed (if in doubt, set true). */
9016 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9022 gfc_ss
*lss_section
;
9029 bool scalar_to_array
;
9033 /* Assignment of the form lhs = rhs. */
9034 gfc_start_block (&block
);
9036 gfc_init_se (&lse
, NULL
);
9037 gfc_init_se (&rse
, NULL
);
9040 lss
= gfc_walk_expr (expr1
);
9041 if (gfc_is_reallocatable_lhs (expr1
)
9042 && !(expr2
->expr_type
== EXPR_FUNCTION
9043 && expr2
->value
.function
.isym
!= NULL
))
9044 lss
->is_alloc_lhs
= 1;
9047 if ((expr1
->ts
.type
== BT_DERIVED
)
9048 && (gfc_is_alloc_class_array_function (expr2
)
9049 || gfc_is_alloc_class_scalar_function (expr2
)))
9050 expr2
->must_finalize
= 1;
9052 if (lss
!= gfc_ss_terminator
)
9054 /* The assignment needs scalarization. */
9057 /* Find a non-scalar SS from the lhs. */
9058 while (lss_section
!= gfc_ss_terminator
9059 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9060 lss_section
= lss_section
->next
;
9062 gcc_assert (lss_section
!= gfc_ss_terminator
);
9064 /* Initialize the scalarizer. */
9065 gfc_init_loopinfo (&loop
);
9068 rss
= gfc_walk_expr (expr2
);
9069 if (rss
== gfc_ss_terminator
)
9070 /* The rhs is scalar. Add a ss for the expression. */
9071 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9073 /* Associate the SS with the loop. */
9074 gfc_add_ss_to_loop (&loop
, lss
);
9075 gfc_add_ss_to_loop (&loop
, rss
);
9077 /* Calculate the bounds of the scalarization. */
9078 gfc_conv_ss_startstride (&loop
);
9079 /* Enable loop reversal. */
9080 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9081 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9082 /* Resolve any data dependencies in the statement. */
9083 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9084 /* Setup the scalarizing loops. */
9085 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9087 /* Setup the gfc_se structures. */
9088 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9089 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9092 gfc_mark_ss_chain_used (rss
, 1);
9093 if (loop
.temp_ss
== NULL
)
9096 gfc_mark_ss_chain_used (lss
, 1);
9100 lse
.ss
= loop
.temp_ss
;
9101 gfc_mark_ss_chain_used (lss
, 3);
9102 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9105 /* Allow the scalarizer to workshare array assignments. */
9106 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9107 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9109 /* Start the scalarized loop body. */
9110 gfc_start_scalarized_body (&loop
, &body
);
9113 gfc_init_block (&body
);
9115 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9117 /* Translate the expression. */
9118 gfc_conv_expr (&rse
, expr2
);
9120 /* Deal with the case of a scalar class function assigned to a derived type. */
9121 if (gfc_is_alloc_class_scalar_function (expr2
)
9122 && expr1
->ts
.type
== BT_DERIVED
)
9124 rse
.expr
= gfc_class_data_get (rse
.expr
);
9125 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9128 /* Stabilize a string length for temporaries. */
9129 if (expr2
->ts
.type
== BT_CHARACTER
)
9130 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9132 string_length
= NULL_TREE
;
9136 gfc_conv_tmp_array_ref (&lse
);
9137 if (expr2
->ts
.type
== BT_CHARACTER
)
9138 lse
.string_length
= string_length
;
9141 gfc_conv_expr (&lse
, expr1
);
9143 /* Assignments of scalar derived types with allocatable components
9144 to arrays must be done with a deep copy and the rhs temporary
9145 must have its components deallocated afterwards. */
9146 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9147 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9148 && !expr_is_variable (expr2
)
9149 && !gfc_is_constant_expr (expr2
)
9150 && expr1
->rank
&& !expr2
->rank
);
9151 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9153 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9154 && gfc_is_alloc_class_scalar_function (expr2
));
9155 if (scalar_to_array
&& dealloc
)
9157 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9158 gfc_add_expr_to_block (&loop
.post
, tmp
);
9161 /* When assigning a character function result to a deferred-length variable,
9162 the function call must happen before the (re)allocation of the lhs -
9163 otherwise the character length of the result is not known.
9164 NOTE: This relies on having the exact dependence of the length type
9165 parameter available to the caller; gfortran saves it in the .mod files. */
9166 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9167 gfc_add_block_to_block (&block
, &rse
.pre
);
9169 /* Nullify the allocatable components corresponding to those of the lhs
9170 derived type, so that the finalization of the function result does not
9171 affect the lhs of the assignment. Prepend is used to ensure that the
9172 nullification occurs before the call to the finalizer. In the case of
9173 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9174 as part of the deep copy. */
9175 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9176 && (gfc_is_alloc_class_array_function (expr2
)
9177 || gfc_is_alloc_class_scalar_function (expr2
)))
9180 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9181 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9182 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9183 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9186 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9187 l_is_temp
|| init_flag
,
9188 expr_is_variable (expr2
) || scalar_to_array
9189 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
9190 gfc_add_expr_to_block (&body
, tmp
);
9192 if (lss
== gfc_ss_terminator
)
9194 /* F2003: Add the code for reallocation on assignment. */
9195 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9196 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9199 /* Use the scalar assignment as is. */
9200 gfc_add_block_to_block (&block
, &body
);
9204 gcc_assert (lse
.ss
== gfc_ss_terminator
9205 && rse
.ss
== gfc_ss_terminator
);
9209 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9211 /* We need to copy the temporary to the actual lhs. */
9212 gfc_init_se (&lse
, NULL
);
9213 gfc_init_se (&rse
, NULL
);
9214 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9215 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9217 rse
.ss
= loop
.temp_ss
;
9220 gfc_conv_tmp_array_ref (&rse
);
9221 gfc_conv_expr (&lse
, expr1
);
9223 gcc_assert (lse
.ss
== gfc_ss_terminator
9224 && rse
.ss
== gfc_ss_terminator
);
9226 if (expr2
->ts
.type
== BT_CHARACTER
)
9227 rse
.string_length
= string_length
;
9229 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9230 false, false, dealloc
);
9231 gfc_add_expr_to_block (&body
, tmp
);
9234 /* F2003: Allocate or reallocate lhs of allocatable array. */
9235 if (flag_realloc_lhs
9236 && gfc_is_reallocatable_lhs (expr1
)
9237 && !gfc_expr_attr (expr1
).codimension
9238 && !gfc_is_coindexed (expr1
)
9240 && !is_runtime_conformable (expr1
, expr2
))
9242 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9243 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9244 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9245 if (tmp
!= NULL_TREE
)
9246 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9249 /* Generate the copying loops. */
9250 gfc_trans_scalarizing_loops (&loop
, &body
);
9252 /* Wrap the whole thing up. */
9253 gfc_add_block_to_block (&block
, &loop
.pre
);
9254 gfc_add_block_to_block (&block
, &loop
.post
);
9256 gfc_cleanup_loop (&loop
);
9259 return gfc_finish_block (&block
);
9263 /* Check whether EXPR is a copyable array. */
9266 copyable_array_p (gfc_expr
* expr
)
9268 if (expr
->expr_type
!= EXPR_VARIABLE
)
9271 /* First check it's an array. */
9272 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9275 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9278 /* Next check that it's of a simple enough type. */
9279 switch (expr
->ts
.type
)
9291 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9300 /* Translate an assignment. */
9303 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9308 /* Special case a single function returning an array. */
9309 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9311 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9316 /* Special case assigning an array to zero. */
9317 if (copyable_array_p (expr1
)
9318 && is_zero_initializer_p (expr2
))
9320 tmp
= gfc_trans_zero_assign (expr1
);
9325 /* Special case copying one array to another. */
9326 if (copyable_array_p (expr1
)
9327 && copyable_array_p (expr2
)
9328 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9329 && !gfc_check_dependency (expr1
, expr2
, 0))
9331 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9336 /* Special case initializing an array from a constant array constructor. */
9337 if (copyable_array_p (expr1
)
9338 && expr2
->expr_type
== EXPR_ARRAY
9339 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9341 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9346 /* Fallback to the scalarizer to generate explicit loops. */
9347 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9351 gfc_trans_init_assign (gfc_code
* code
)
9353 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9357 gfc_trans_assign (gfc_code
* code
)
9359 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);